





Six great reasons to join EIX today 


• Over 140 microcomputer-related conferences: 

loin only those subjects that interest you and change 
selections at any time. Tcike part when it's convenient 
for you. Share information, opinions and ideas in 
focused discussions with other BIX users who share 
your interests. Easy commands and conference digests 
help you quickly locate important information. 

• Monthly conference specials: 

BIX specials connect you with invited experts in lead¬ 
ing-edge topics—CD-ROM. MIDI. OS-9 and more. 
They're all part of your BIX membership. 

• Microbytes daily: 

Get up-to-the-minute industry news and new product 
information by joining Microbytes Daily and What's 
New Hardware and Software. 

• Public domain software: 

Yours for the downloading, including programs from 
BYTE articles and a growing library of PD listings. 

• Electronic mail: 

Exchange private messages with BYTE editors and 
authors and other BIX users. 



BIX User's Manual and Subscriber Agreement 
as Soon as We've Processed Your Registration. 
JOIN THE EXCITING WORLD 
OF BIX TODAY! 


• Vendor support: 

A growing number of microcomputer manufacturers 
use BIX to answer your questions about their products 
and how to use them for peak performance. 


What BIX Costs. .How You Pay 


JOIN BIX RIGHT NOW: 

Set your computer's telecommunications program for 
full duplex. 8-bit characters, even parity. 1 stop bit OR 
7-bit characters, even parity. 1 stop using 300 or 1200 
baud. 

Call your local Tymnet number and respond as follows: 


ONE-TIME REGISTRATION FEE S25 


Hourly 

Charges: 

(Your Time 
of Access) 


Off-Peak 

6PM-7AM 

Weekdays Plus 
Weekends 
& Holidays 


Peak 

7AM-6PM 

Weekdays 


Tymnet Prompt 

Garble or "terminal identifier” 

login: 

password: 

mhis login: 

BIX Logo—Name: 


You Enter 

a 

byteneti <CR> 
mgh <CR> 
bix <CR> 
new <CR> 


BIX $9 $12 

Tymnet* $2 $6 

TOTAL SI I/hr. $I8/hr.** 

■ Continental U S. BIX is accessible via Tymnet from throughout the US. at charges 
much less than regular long distance. Call the BIX helpline number listed below 
for the Tymnet number near you or Tymnet at 1-800-336-0149 
' * User is billed for time on system lie.. VS Hr. Off-Peak wTTymnet - S5.50 charge .I 

BIX and Tymnet charges billed by Visa or Mastercard only. 

BIX Helpline 

(8:30 AM-11:30 PM Eastern Weekdays) 

U.S. (except NH)-l-800-227-BYTE 
Elsewhere (603) 924-7681 


After you register on-line, you're immediately taken to 
the BIX learn conference and can start using the system 
right away. 

Foreign access: 

To access BIX from foreign countries, you must have 
an account with your local Postal Telephone & Telegraph 
(PTT) company. From your PTT enter 310600157878. 
Then enter bix <CR> and new <CR> at the prompts. 
Call or write us for PTT contact information. 

EIX 

One Phoenix Mill Lane 
Peterborough, NH 03458 
(603) 924-9281 
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WELCOME TO BYTE’S 
QUARTERLY LISTINGS SUPPLEMENT 

The BYTE Listings Supplement is produced quarterly as a 
means of providing interested readers with a printed, source 
code version of those programs referenced in BYTE articles. 

It provides a far more extensive look into the techniques of 
coding and the potentialities of microcomputers than we have 
space for in each month’s BYTE. 

Programs contained in this Supplement are referenced by 
the month the article appeared, the page on which their sup¬ 
porting article begins, and the name of the author who wrote 
the article. 

For those who prefer programs already in electronic for¬ 
mat, we have a companion service called Listings on Disk. If 
you have a modem, listings may be downloaded from the 
BYTEnet bulletin board and, if you are a member of BIX, 
the “Listings” area also contains programs referenced in 
BYTE. 

If you live outside of the U.S., we’ve included the names, 
addresses and telephone numbers of bulletin boards that get 
program code from us. You’ll find the directory just inside 
the back cover of this Supplement. 

The bulletin boards are updated monthly. Several coun¬ 
tries have enough boards that the telephone charges for most 
callers should be the minimum possible. 


Copyright © 1987 by McGraw-Hill Inc. All rights reserved. 
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BENCH. ADA Contributed by Namir Clement Shammas. 

Listings accompany the review of four Ada compilers: Alsys Ada, Artek Ada, AdaVantage, and JANUS Ada, "Ada Moves to Micros," July 
1987, page 239. 


Listing 1: Source code for Ada Sieve benchmark program. 

with TEXT_IO; 
use TEXT.IO; 

— package INTIO is new INTEGER__IO( INTEGER); 

PROCEDURE MTSIE10 is 

SIZE : constant INTEGER := 7000; 

TYPE Flag_Array is array(0. .SIZE) of BOOLEAN; 

PRIME, K, COUNT : INTEGER; 

FLAGS : Flag_Array; 

BEGIN 

PUT_LINE(’'START TEN ITERATIONS”); 

FOR ITER INI.. 10 LOOP 
COUNT := 0; 

FORI IN 0.. SIZE LOOP 
FLAGS(I) := TRUE; 

END LOOP; 

FORI IN 0.. SIZE LOOP 

IF FLAGS(I) THEN 
PRIME := I + 1 + 3; 

K := I + PRIME; 

WHILE K <= SIZE LOOP 
FLAGS(K) := FALSE; 

K : = K + PRIME; 

END LOOP; 

COUNT : = COUNT + 1; 

END IF; 

END LOOP; 

END LOOP; 

PUT(INTEGER'IMAGE(COUNT)); 

PUT_LINE(" PRIMES"); 

END MTSIE10; 


Listing 2: Source code for Ada integer Sort benchmark program. 

with TEXT.IO; 
use TEXT.IO; 

Procedure MTSort2 is 

— Program will test the speed of sorting an integer array. 

— The program will create an array sorted from smaller to larger 

— integers, then sort them in the reverse order. 

— The array is reverse-sorted ten times. 

continued 
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package INTIO is new INTEGER_IO( INTEGER); 

SIZE : constant :* 1000; 

TYPE NUMBERS is ARRAY(1. .SIZE) OF INTEGER; 

InOrder, AscendingOrder : BOOLEAN; 

Offset, Temporary : INTEGER; 

Ch : CHARACTER; 

A : NUMBERS; 

PROCEDURE InitializeArray is 

— Procedure to initialize array 
BEGIN 

PUT_LINE("Initializing integer array"); 

FORI INI.. SIZE LOOP 
A(I) := I; 

END LOOP; 

END InitializeArray; 

PROCEDURE ShellSort is 

— Procedure to perform a Shell-Metzner sorting 
I : INTEGER; 

PROCEDURESwapThem(I, J : in INTEGER) is 

— Local procedure to swap elements A(I) and A(J) 

BEGIN 

InOrder := FALSE; 

Temporary := A(I); 

A(l) := A(J); 

A(J) :* Temporary; 

END SwapThem; 

BEGIN 

— Toggle "AscendingOrder" flag status 
Ascend ingOrder :* NOT AscendingOrder; 

Offset := SIZE; 

WHILE Of fset > 1 LOOP 
Offset :« Offset/2; 

LOOP 

InOrder := TRUE; 

FOR J IN 1.. (SIZE - Offset) LOOP 
I : = J + Offset; 

IF AscendingOrder 

THEN IF A(I) < A(J) THEN SwapThem(I, J); END IF; 
ELSE IF A(I) > A(J) THEN SwapThem (I, J); END IF; 
END IF; — AscendingOrder 
END LOOP; 

IF InOrder THEN EXIT; END IF; 

END LOOP; 

END LOOP; 

END ShellSort; 

PROCEDURE DisplayArray is 

— Display array members 
BEGIN 

FORI INI.. SIZE LOOP 
INTIO.PUT(A(I) ,3) ; 

p UT (» »•); 

END LOOP; 

NEW_LINE; 

END DisplayArray; 

BEGIN — Main 
InitializeArray; 

AscendingOrder :* TRUE; 

PUT("Beginning to sort press <cr> "); GET(Ch); NEW.LINE; 
FOR Iter INI.. 10 LOOP 
PUT(".»); 

ShellSort; 

END LOOP; 

PUT_LINE("Finished sorting!"); 

DisplayArray; 

END MTSort2; 
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Listing 3: Source code for Ada basic Floating benchmark program. 

WITH TEXT.IO; USE TEXT.IO; 

PROCEDURE MTFLOAT is 

PACKAGE ReallnOut is new FLOAT. 10(FLOAT); 

USE ReallnOut; 

NR : CONSTANT INTEGER := 5000; 

A, B, C : FLOAT; 

BEGIN 

A :* 2.71828; 

B := 3.1459; 

C := 1.0; 

FORI INI..NR LOOP 
C :» C * A; 

C :»C*B; 

C :=C/A; 

C := C / B; 

END LOOP; 

PUT("D0NE"); 

NEW.LINE; 

PUT("ERROR »"); 

PUT((C-1.0)); 

NEW.LINE; 

END MTFLOAT; 

Listing 4: Source code for Ada matrix-inversion Floating benchmark program. 

with TEXT.IO; 
use TEXT.IO; 

Procedure MTINVERT is 

— Program to test speed of floating-point matrix inversion. 

— The program will form a matrix with Is in every member, 

— except the diagonals which will have values of 2. 

package ReallnOut is new FLOAT. 10(FLOAT); 

MAX : constant :* 20; 

TYPE MATRIX is ARRAY (1..MAX, 1. .MAX) OF FLOAT; 

J, K, L: INTEGER; 

DET, PIVOT, TEMPO: FLOAT; 

A: MATRIX; 

Procedure Invert is 

BEGIN 

— Creating test matrix 
FOR J INI.. MAX LOOP 

FORK INI.. MAX LOOP 
A(J, K) :■ 1.0; 

END LOOP; 

A(J, J) :■ 2.0; 

END LOOP; 


PUT_LINE("Startingmatrix invertion"); 


DET :» 1.0; 

continued 
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FOR J INI..MAX LOOP 

PIVOT := A(J, J); 

DET : = DET#PIVOT; 

A(J, J) := 1.0; 

FORK INI.. MAX LOOP 

A(J, K) := A(J, K)/ PIVOT; 

END LOOP; 

FORK INI.. MAX LOOP 

IF K/* J THEN 

TEMPO : = A(K, J); 

A(K, J) : = 0.0; 

FOR L INI..MAX LOOP 

A(K, L) := A(K, L) - A(J, L) # TEMPO; 

END LOOP; 

END IF; 


END LOOP; 

END LOOP; 

END Invert; 

BEGIN 

NEWSLINE(2); 

Invert; 

PUT( "Determinant = "); 

RealInOut.PUT(DET,14,10); 
NEW_LINE(2); 

END MT INVERT; 


Listing 5: Source code for Ada Math Functions benchmark program. 

— use Janus/Ada libraries 
WITH TEXT_I0; WITH SMATHLIB; 

USE TEXT_IO; USE SMATHLIB; 

PROCEDURE MTMath is 

— Program tests the speed of math function. 

— Each function is timed separately. 

— Functions are shown in the import list. 


pi, angle, result, argument: FLOAT; 
dummy: CHARACTER; 

BEGIN 

PUT_LINE("START SQUARE ROOT TEST"); 

PUT( "PRESS <CR> TO START"); 

GET(dummy); New.Line; 

FOR i ini.. 10 LOOP 
PUT("."); 
argument := 0.0; 

WHILE argument <= 1000.0 LOOP 
result :» Sqrt(argument); 
argument := argument + 1.0; 

END LOOP; 

END LOOP; 

New_Line; PUT("END OF SQUARE ROOT TEST"); Nev_Line; 
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PUT("START LOG TEST"); 

Nev_Line; 

PUT("PRESS <CR> TO START"); 

GET(dummy); New_Line; / 

FOR i ini.. 10 LOOP 
PUT("."); 
argument :* 0.1; 

WHILE argument <= 1000.1 LOOP 
result : = Log(argument); 
argument : = argument + 1.0; 

END LOOP; 

END LOOP; 

New.Line; PUT("END0F LOG TEST"); Nev_Line; 

PUT("START EXPONENTIAL TEST"); 

New_Line; 

PUT ("PRESS <CR> TO START"); 

GET (dummy); New_Line; 

FOR i ini..10 LOOP 
PUT("."); 
argument := 0.1; 

WHILE argument <=10.0 LOOP 
result := exp(argument); 
argument : = argument + 0.01; 

END LOOP; 

END LOOP; 

New_Line; PUT( "END OF EXPONENTIAL TEST"); New_Line; 

PUT( "START ARCTANGENT TEST"); 

New_Line; 

PUT( "PRESS <CR> TO START"); 

GET (dummy); New_Line; 

FOR i ini..10 LOOP 
PUT("."); 
argument :* 0.1; 

WHILE argument <=10.0 LOOP 
angle := arctan(argument); 
argument : = argument + 0.01; 

END LOOP; 

END LOOP; 

New.Line; PUT( "END OF ARCTANGENT TEST"); New_Line; 


pi := 355.0/113.0; 

PUT( "START SINE TEST"); 

New_Line; 

PUT( "PRESS <CR> TO START"); 

GET (dummy); New_Line; 

FOR i ini.. 10 LOOP 
PUT("."); 
angle :■ 0.0; 

WHILE angle <= 2.0 * pi LOOP 
result :■ sin(angle); 
angle := angle + pi/360.0; 

END LOOP; 

END LOOP; 

New_Line; PUT("END OF SINE TEST"); Nev_Line; 

New_Line; 

PUT("DONE"); New_Line; New.Line; 

END MTMath; 

Listing 6: Source code for Ada Recursion benchmark program. 

with TEXT_I0; 
use TEXT_IO; 

Procedure MTQSort la continued 
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— The test uses Quicksort to measure recursion speed. 

— An ordered array is created by the program and is 

— reverse-sorted. The process is performed "MAX I TER" 

— number of times. 

package Int_IO is new INTEGER_IO(INTEGER); 

SIZE : constant := 1000; 

MAXITER : constant :=10; 

WantToListArray : constant BOOLEAN FALSE; — Flag used for debugging 
TYPE Numbers is ARRAY(1. .SIZE) OF INTEGER; 

A : Numbers; 

PROCEDURE InitializeArray is 

— Procedure to initialize array 

BEGIN 

FORI ini.. SIZE LOOP 
A(I) := SIZE-1 + 1$ 

END LOOP; 

NEW_LINE(3); 

END InitializeArray; 

PROCEDURE Quicksort is 

— Procedure to perform a Quicksort 

PROCEDURESort(Left, Right : INTEGER) is 

i, J ; INTEGER; 

Datal, Data2 : INTEGER; 

BEGIN 

i := Left; J Right; 

Datal : = A( (Left + Right) / 2); 

LOOP 

WHILE A(i) < Datal LOOP i :* 1 + 1; END LOOP; 

WHILE Datal < A(J) LOOP J :■ J -1; END LOOP; 

IF i <= J THEN 

Data2 :* A(i); A(i) := A(J); A(j) :=Data2; 
i ;• i + 1; 

J := J -1; 

END IF; 

IFi> j THEN EXIT; END IF; 

END LOOP; 

IF Left < j THEN Sort(Left, j); END IF; 

IF i < Right THEN Sort(i,Right); END IF; 

END Sort; 

BEGIN 

Sort(l,SIZE); 

END Quicksort; 

PROCEDURE DisplayArray is 

— Display array members 
BEGIN 

FORI ini.. SIZE LOOP 
Int_I0.PUT(A(I),4); 

PUT(" "); 

END LOOP; 

NEW_LINE; 

END DisplayArray; 

BEGIN — Main 

FOR Iter in 1. .MAXITER LOOP 
InitializeArray; 

PUT("."); 

Quicksort; 

END LOOP; 

NEW.LINE; 

PUT_LINE("Finished sorting!"); 

IF WantToListArray THEN DisplayArray; END IF; 

END MTQSort; 
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Listing 7: Source code for Ada Dynamic Allocation benchmark program. 


with TEXT_I0; 
use TEXT_I0; 

PROCEDURE MTPtr is 

— Program to measure the speed of: 

— 1) Allocating dynamic binary-tree structure 

— 2) Searching through the binary tree 


SIZE : constant INTEGER := 1000; 

MainLoopCount : constant INTEGER := 200; 

TYPE Node; 

TYPE Ptr is access Node; 

TYPE Node is record 

Value : INTEGER; 

Left, Right : Ptr; 
end record; 

TYPE NumbersArray is ARRAY (1. .SIZE) OF INTEGER; 

Numbers : NumbersArray; 

TreeRoot : Ptr; 
dummy : CHARACTER; 


PROCEDURE Create is 
J : INTEGER := 1; 

BEGIN 

WHILE J <* SIZE LOOP 

IF (J >= l) AND (J< 251) THEN 
Numbers(J) := J; 

ELSIF (J > 250) AND (J < 501) THEN 
Numbers (J) :=SIZE-J; 

ELSIF (J > 500) AND (J < 750) THEN 
Numbers(J) := J; 

ELSE 

Numbers (J) :=SIZE-J; 

END IF; 

J := J + 1; 

PUT(INTEGER'IMAGE(J) &" "); 

END LOOP; 
new_line; 

END Create; 

PROCEDURE Insert(Root : in out Ptr; Item : INTEGER) is 

— Insert element in binary tree 

BEGIN 

IF Root = null THEN 
Root := new Node; 

Root.Value :■ Item; 

Root.Left :« null; 

Root.Right := null; 

ELSE 

IF Item< Root.Value THEN Insert(Root.Left, Item); 

ELSE Insert(Root.Right,Item); 

END IF; 

END IF; 

END Insert; 


PROCEDURE Search (Root : in out Ptr; Target : INTEGER) is 
-- Recursive procedure to search for Target value 


continued 
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BEGIN 

IF not (Root=null) THEN 
IF not (Target = Root. Value) THEN 
IF Target < Root .Value THEN 
Root := Root. Left; Search (Root, Target); 

ELSE 

Root := Root.Right; 

Search(Root,Target); 

END IF; 

END IF; 

END IF; 

END Search; 

BEGIN — MAIN 
Create; 

PUT_LINE("Created array"); 

— Building the binary tree 

PUT("Press <CR> to time tree creation "); 

GET(dummy); NEW.LINE; 

TreeRoot ;= null; 

FORI INI.. SIZE LOOP 
Insert(TreeRoot,Numbers(I)); 

END LOOP; 

NEW.LINE; 

PUT_LINE( "Created Tree"); 

PUT("Press <CR> to time tree search "); 

GET (dummy); NEVLLINE; 

FOR Iter IN 1. .MainLoopCount LOOP 
FOR I IN reverse 1. .SIZE LOOP 
Search(TreeRoot,Numbers(I)); 

END LOOP; 

END LOOP; 

NEVLLINE; 

PUT_LINE("DONE"); 

END MTPtr; 

Listing 8: Source code for Ada Disk Write benchmark program. 

with TEXT.IO; 
use TEXT_IO; 

Procedure MTWRITE is 

Num_Rec : constant := 512; 

Small : STRING(1..30); 

Big : STRING(1..120); 

F : FILE_TYPE; 

BEGIN 

Small(l..30) :« "123456781234567812345678123456"; 

Big : = Small & Small & Small & Small; 

CREATE(F, 0UT_FILE, "AjTEMP0.DAT"); 

FOR I in 1. .Num_Rec LOOP 
PUT_LINE(F, Big); 

END LOOP; 

CLOSE(F); 

PUT_LINE("DONE"); 

END MTWRITE; 

Listing 9: Source code for Ada Disk Read benchmark program. 

with TEXT_I0; 
use TEXT_I0; 

Procedure MTREAD is 

Num_Rec : constant :* 512; 

Big : STRING(1..120); 

Last : NATURAL; 

F : FILEJTYPE; 
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BEGIN 

OPEN(F,IN.FILE,"A:TEMPO.DAT"); 

FOR I in 1.. Num_Rec LOOP 
GET_LINE(F, Big, Last); 

END LOOP; 

CLOSE(F); 

PUT_LINE("DONE"); 

END MTREAD; 


DHRY.C Dhrystone benchmark program by Re inhold P. Weicker, translated from Ada by Rick Richardson. 

Listing accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


ft 

# 

# 

# 

ft 

* 

# 

# 

ft 

ft 

* 

ft 

ft 

ft 

ft 

* 

* 

* 

ft 

ft 

ft 

ft 

* 

ft 

ft 

# 

* 

* 

* 

* 

* 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 


EVERBODY: Please read "APOLOGY" below, -rick 01/06/85 

See introduction in net.arch, or net.micro 


"DHRYSTONE" Benchmark Program 


Version: 

Date: 

Author: 

Compile: 

Defines: 


Run: 

Results: 


Note: 


C/1.1, 12/01/84 

PROGRAM updated 01/06/86, RESULTS updated 03/31/86 

Reinhold P. Weicker, CACMvol. 27, no. 10, 10/84, pg. 1013 
Translated from Ada by Rick Richardson 

Every method to preserve Ada likeness has been used, at the expense of C-ness. 

cc -0 dry.c -o drynr : No registers 

cc -0 -DREG=register dry.c -o dryr : Registers 

Defines are provided for old C compilers that don* t have enums and can't assign structures. 

The time(2) function is library-dependent; most return the time in seconds, but beware of some, 
like Aztec C, which return other units. The LOOPS define is initially set for 50,000 loops. 

If you have a machine with large integers and is very fast, please change this number to 500,000 to 
get better accuracy. Please select the way to measure the execution time using the TIME define. 
For single-user machines, time(2) is adequate. For multiuser machines where you cannot get 
single-user access, use the times(2) function. If you have neither, use a stopwatch in the dead of 
night. Use a "printf" at the point marked "start timer" to begin your timings. DO NOT use the Unix 
time(l) command, as this will measure the total time to run this program, which will 
(erroneously) include the time to malloc(3) storage and to compute the time it takes to 
do nothing. 

drynr; dryr 

If you get any new machine/OS results, please send to: 
ihnp4!castor!pcrat1 rick 

and thanks to all that do. Space prevents listing the names of those who have provided some of 
these results. I'll be forwarding these results to Re inhold P. Weicker. 

I order the list in increasing performance of the "with registers" benchmark. If the compiler 
doesn't provide register variables, then the benchmark is the same for both REG and N0REG. 


* PLEASE: 

ft 

ft 


Send complete information about the machine type, clock speed, OS, and C manufacturer/version. 
If the machine is modified, tell me what was done. On Unix, execute uname -a and cc -V to get 
this info. 


* 80x8x NOTE: 80x8x benchers: Please try to do all memory models for a particular compiler. 

ft 

* APOLOGY (1/30/86): 

* Well, I goofed things up! As pointed out by Haakon Bugge, the line of code marked "GOOF" below was 

* missing from the Dhrystone distribution for the last several months. It #WAS* in a backup copy I made 

* last winter, so no doubt it was victimized by sleepy fingers operating vil 

ft 

* The effect of the line missing is that the reported benchmarks are 15 percent too fast (at least on an 

* 80286). Now, this creates a dilemma- -do I throw out ALL the data so far collected and use only results 

» from this (corrected) version, or do I Just keep collecting data for the old version? 


continued 
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* 

* Since the data collected so far #is* valid as long as it is compared with like data, I have decided to 

a keep TWO lists—one for the old benchmark, and one for the new. This also gives me an opportunity to 

a correct one other error I made in the instructions for this benchmark. My experience with C 

* compilers has been mostly with Unix 'pcc'-derived compilers, where the 'optimizer* simply fixes 

* sloppy code generation (peephole optimization). But today, there exist C compiler optimizers that 

a will actually perform optimization in the computer science sense of the word, by removing, for example, 

* assignments to a variable whose value is never used. Dhrystone, unfortunately, provides lots of 

a opportunities for this sort of optimization. 

* 

a I request that benchmarkers re-run this new, corrected version of Dhrystone, turning off or bypassing 

a optimizers that perform more than peephole optimization. Please indicate the version of Dhrystone 

a used when reporting the results to me. 

# 

a RESULTS BEGIN HERE 
# 

a..DHRYSTONE VERSION 1.1 RESULTS BEGIN.. 


* 


* MACHINE 

MICROPROCESSOR 

OPERATING 

COMPILER 

DHRYSTONES/SEC. 

* TYPE 


SYSTEM 


NO REG 

REGS 

a Apple He 

65C02-1.02 MHz 

DOS 3.3 

Aztec CII vl.05i 

37 

37 

* . 

Z80-2.5 MHz 

CPM-80 v2.2 

Aztec CII vl.05g 

91 

91 

# - 

8086-8 MHz 

RMX86 V6 

Intel C-86 V2.0 

197 

203LM? ? 

a IBM PC XT 

8088-4.77 MHz 

COHERENT 2.3.43 

Mark Williams 

259 

275 

# - 

8086-8 MHz 

RMX86 V6 

Intel C-86 V2.0 

287 

304 ?? 

* Fortune 32:16 

68000-6 MHz 

V7+sys3+4.1BSD 

cc 

360 

346 

* PDP-11/34A 

w/FP-HC 

UNIX V7m 

cc 

406 

449 

a Macintosh 512 

68000-7.7 MHz 

Mac ROM 0/S 

DeSmet(C ware) 

625 

625 

* VAX-11/750 

w/FPA 

UNIX 4.2BSD 

cc 

831 

852 

a DataMedia 932 

68000-10 MHz 

UNIX sysV 

cc 

837 

888 

a Plexus P35 

68000-12.5 MHz 

UNIX sysIII 

cc 

835 

894 

* ATT PC7300 

68010-10 MHz 

UNIX 5.0.3 

cc 

973 

1034 

a Compaq II 

80286-8 MHz 

MSDOS 3 • 1 

MS C 3.0 

1086 

1140 LM 

a IBM PC AT 

80286-7.5 MHz 

Venlx/286 SVR2 

cc 

1159 

1254 *15 

a Compaq II 

80286-8 MHz 

MSDOS 3.1 

MS C 3.0 

1190 

1282 MM 

a MicroVAX II 

- 

Mach/4.3 

cc 

1361 

1385 

a DEC uVAX 11 

- 

Ultrix-32m vl.l 

cc 

1385 

1399 

a Compaq II 

80286-8 MHz 

MSDOS 3.1 

MS C 3.0 

1351 

1428 

# VAX-11/780 

- 

UNIX 4.2BSD 

cc 

1417 

1441 

a VAX-780/MA780 

- 

Mach/4.3 

cc 

1428 

1470 

a VAX-11/780 

- 

UNIX 5.0.1 

cc 4.1.1.31 

1650 

1640 

a Ridge 32C VI 

- 

ROS3-3 

Ridge C (older) 

1628 

1695 

a Gould PN6005 

- 

UTX l.lc-f (4.2) 

cc 

1732 

1884 

a Gould PN9080 

custom ECL 

UTX-321.1C 

cc 

4745 

4992 

a VAX-784 

- 

Mach/4.3 

cc 

5263 

5555 &4 

a VAX 8600 

- 

4.3 BSD 

cc 

6329 

6423 

a Amdahl 5860 

- 

UTS sysV 

cc 1.22 

28,735 

28,846 

a IBM3090/200 
# 

- 

? 

? 

31,250 

31,250 

* 

*- 


- DHRYSTONE VERSION 1.0 RESULTS BEGIN.. 



a MACHINE 

MICROPROCESSOR 

OPERATING 

COMPILER 

DHRYSTONES/SEC. 

a TYPE 


SYSTEM 


NO REG 

REGS 

a Commodore 64 

6510-1 MHz 

C64 ROM 

C Power 2.8 

36 

36 

a HP-110 

8086-5.33 MHz 

MS-D0S2.il 

Lattice 2.14 

284 

284 

a IBM PC XT 

8088-4.77 MHz 

PC/ IX 

cc 

271 

294 

a CCC3205 

- 

Xelos(SVR2) 

cc 

558 

592 

a Perq-II 

2901bltslice 

Accent S5c 

cc (CMU) 

301 

301 

a IBM PC XT 

8088-4.77 MHz 

COHERENT 2.3.43 

Mark Williams cc 

296 

317 

a Cosmos 

68000-8 MHz 

UniSoft 

cc 

305 

322 

a IBM PC XT 

8088-4.77 MHz 

Venix/86 2.0 

cc 

297 

324 

a DEC PRO 350 

11/23 

Venix/PRO SVR2 

cc 

299 

325 

a IBM PC 

8088-4.77 MHz 

MS-DOS 2.0 

bl6cc 2.0 

310 

340 

a PDP11/23 

11/23 

Venix (V7) 

cc 

320 

358 

a Commodore Amiga 


? 

Lattice 3.02 

368 

371 

a PC XT 

8088-4.77 MHz 

Venix/86 SYSV 

cc 

339 

377 

a IBM PC 

8088-4.77 MHz 

MS-DOS 2.0 

CI-C86 2.20M 

390 

390 

a IBM PC XT 

8088-4.77 MHz 

PC-DOS 2.1 

Wizard 2.1 

367 

403 

a IBM PC XT 

8088-4.77 MHz 

PC-D0S 3*1 

Lattice 2.15 

403 

403 @ 

a ColexDM-6 

68010-8 MHz 

Unlsoft SYSV 

cc 

378 

410 

a IBM PC 

8088-4.77 MHz 

PC-DOS 3.1 

Datalight 1.10 

416 

416 

a IBM PC 

NEC V20-4.77 MHz 

MS-DOS 3.1 

MS 3.1 

387 

420 

a IBM PC XT 

8088-4.77 MHz 

PC-DOS 2.1 

Microsoft 3*0 

390 

427 
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* IBM PC 

* PDP-11/34 

* IBM PC 

* Tandy 1000 

* Tandy TRS-16B 

* PDP-11/34 

* Onyx C8002 

* Tandy TRS-16B 

* DEC PRO 380 

* FHLQT+ 

* Apollo DN550 

* HP-110 

* ATT PC6300 

* IBM PC AT 

* Tandy 6000 

* IBM PC AT 

* Macintosh 

* Macintosh 

* Macintosh 512 

* IBM PC AT 

* Codata 3300 

* WICATMB 

* Cadmus 9000 

* AT&T 6300 

* Cadmus 9790 

* NEC PC9801F 

* ATT PC6300 

* Burroughs XE550 

* EAGLE/TURBO 

* ALTOS 586 

* DEC 11/73 

* ATT 3B2/300 

* Apollo DN320 

* IRIS-2400 

* Atari 520ST 

* IBM PC AT 

* WICATMB 

* VAX-11/750 

* CCC7350A 

* VAX-11/750 

* Fast Mac 

* IBM PC XT 

* DEC 11/44 

* Macintosh 

* CCC3210 

* ccc 3220 

* IBM PC AT 

* AT&T 6300 

* IBM PC AT 

* VAX-11/750 

* IBM PC XT 

* IBM PC XT 

* Plexus P35 

* PDP-11/73 

* VAX-11/750 

* IRIS-1400 

* IBM PC AT 

* IBM PC AT 

* Zilog S8000/11 

* NSC ICM-3216 

* IBM PC AT 

* VAX-11/750 

* Stride 

* Plexus P/60 

* ATTPC7300 

* ccc 3230 

* Stride 

* IBM PC AT 

* Plexus P/60 

* IBM PC AT 

x ATT PC6300+ 

» IBM PC AT 

* Sun 2/120 

* IBM PC AT 

* WICATPB 


NEC V20-4.77 MHz 

8088, 4.77MHz 
V20, 4.77 MHz 
68000-6 MHz 

Z8000-4 MHz 
68000-6 MHz 
11/73 

68000-10 MHz 
68010-? MHz 
8086-5.33 MHz 
8086-8 MHz 
80286-6 MHz 
68000-8 MHz 
80286-6 MHz 
68000-7.8 MHz 2M 
68000-7.7 MHz 
68000-7.7 MHz 
80286-6 MHz 
68000-8 MHz 
68000-8 MHz 
68010-10 MHz 
8086-8 MHz 
68010-10 MHz 1MB 
8086-8 MHz 
8086-8 MHz 
68010-10 MHz 
8086-8 MHz 
8086-10 MHz 
J-ll micro 
WE32000-? MHz 
68010-? MHz 
68010-10 MHz 
68000-8 MHz 
80286-6 MHz 
68000-8 MHz 

68000-8 MHz 

68000-7.7 MHz 
8086-9.54 MHz 

68000-7.8 MHz 2M 


80286-6 MHz 
8086, 8 MHz 
80286-6 MHz 
w/FPA 

8086-9.54 MHz 
8086-9.54 MHz 
68000-10 MHz 
KDJ11-AA 15 MHz 
w/FPA 

68010-10 MHz 
80286-6 MHz 
80286-6 MHz 
Z8001-5.5 MHz 
NSC 32016-10 MHz 
80286-6 MHz 
w/FPA 

68000-10 MHz 
MC68000-12.5 MHz 
68010-10 MHz 

68000-12 MHz 
80286-6 MHz 
MC68000-12.5 MHz 
80286-6 MHz 
80286-6 MHz 
80286-6 MHz 
68010-10 MHz 
80286-6 MHz 
68000-8 MHz 


MS-DOS 3.1 
Unix V7M 
PC-DOS 2.1 
MS-D0S2.il 
Xenix 1.3.5 
RSTS/E 
IS/11.1 (V7) 
Xenix 1.3.5 
Venix/PRO SVR2 
Os9/68000 
AegisSR9/IX 
MS-D0S2.il 
MS-D0S2.il 
PC-DOS3.0 
Xenix 3.0 
Xenix 3.0 
Mac Rom 

Mac ROM 0/S 
Xenix 3.0 
UniPlus+ (v7) 
System V 
Unix 

Venix/86 SVR2 
SVR0,Cadmus3.7 
PC-D0S2.il 
MS-D0S2.il 
Centix 2.10 
Venix/86 SVR2 
Xenix 3.0b 
Ultrix-11 V3.0 
Unix 5.0.2 
AegisSR9/IX 
Unix System V 
TOS 

PC-DOS3.0 
System V 
Ultrix 1.1 
UniSoft V.2 
Unix 4.2bsd 

PC-DOS3-1 
Ultrix-11 V3.0 
Mac Rom 

Xelos R01(SVR2) 
Ed. 7v2.3 
Xenix 3.0 
MS-D0S2.il 
Xenix 3.0 
Eunice 3*2 
PC-DOS3.1 
PC-DOS3.1 
Unix System III 
Unix V7M2.1 
Unix 4.3bsd 
Unix System V 
Venix/86 2.1 
PC-DOS 3.0 
Zeus 3.2 
Unix SVR2 
PC-DOS3.0 
VMS 

System-V/68 
Unix SYSIII 
Unix 5.0.2 
Xelos R0l(SVR2) 
System-V/68 
Venix/286 SVR2 
Unix SYSIII 
PC-DOS 3.0 
MS-DOS 3.1 
PC-DOS 3.1 
Sun 4.2BSD 
PC-DOS3.0 
System V 


MS 3.1 (186) 
cc 

Aztec C v3.2d 
Aztec C v3.2d 
cc 

decus c 
cc 

Green Hills 
cc 

version 1.3 
cc 3*12 
Aztec C 
bl6cc 2.0 
CI-C86 2.1 
cc 
cc 

Mac C 32 bit int 
MegaMax C 2.0 
DeSmet(C ware) 
cc 
cc 

WICAT C 4.1 

cc 

cc 

cc 

Lattice 2.15 

CI-C86 2.20M 

cc 

cc 

cc 

cc 

cc 

cc 3 • 12 
cc 

DigResearch 
MS 3.0(large) 
WICATC4.1 
4.2BSD cc 
cc 
cc 

MegaMaxC2.0 
Microsoft 3*0 
cc 

Mac C 16 bit int 

cc 

cc 

cc -i 

Aztec C v3.2d 

cc 

cc 

Wizard 2.1 

Lattice 2.15 

cc 

cc 

cc 

cc 

cc 

bl6cc 2.0 

cc 

cc 

MS 3.0(small) 
VAX-11C2.0 
cc 

Plexus 

cc 

.cc 

cc 

cc ( , 

Plexus 

Datalight 1.10 
bl6cc 2.0 
Wizard 2.1 
cc 

CI-C86 2.20M 
WICATC4.1 


393 

427 

387 

438 

423 

454 

423 

458 

438 

458 

438 

495 

476 

511 

609 

617 

577 

628 

603 

649 FH 

666 

666 

641 

676 

632 

684 

666 

684 

694 

694 

684 

704 MM 

694 

704 

661 

709 

714 

714 

704 

714 LM 

678 

725 

585 

731 

714 

735 

668 

743 

720 

747 

768 

- @ 

769 

769 

769 

769 CT1 

696 

779 

724 

793 

735 

793 

735 

806 

806 

806 

772 

829 

839 

846 

833 

847 LM 

675 

853 S 

781 

862 

821 

875 

862 

877 

839 

904 + 

833 

909 Cl 

862 

909 

877 

909 S 

849 

924 

892 

925 

909 

925 

862 

943 

892 

961 

914 

976 

892 

980 Cl 

980 

980 Cl 

984 

980 

862 

981 

994 

997 

909 

1000 

961 

1000 

943 

1063 

1011 

1084 

1041 

1084 

1063 

1086 

958 

1091 

1041 

1111 

1111 

1111 

1041 

1111 

1040 

1126 

1063 

1136 

1056 

1149 

Ull 

1163 T 

1190 

1190 

1111 

1219 

1136 

1219 

1136 

1219 

1219 

1219 

998 

1226 
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* MASSCOMP 500 

68010-10 MHz 

RTU V3.0 

cc (V3.2) 

1156 

1238 

* Alliant FX/8 

IP (68012-12 MHz) 

Concentrix 

cc -ip;exec -i 

1170 

1243 FX 

* CybDataMate 

68010-12.5 MHz 

Uniplus 5.0 

Unisoft cc 

1162 

1250 

* PDP 11/70 

- 

Unix 5.2 

cc 

1162 

1250 

* IBM PC AT 

80286-6 MHz 

PC-DOS 3*1 

Lattice 2.15 

1250 

1250 

* IBM PC AT 

80286-7.5 MHz 

Venix/86 2.1 

cc 

1190 

1315 *15 

* Sun2/120 

68010-10 MHz 

Standalone 

cc 

1219 

1315 

* Intel 380 

80286-8 MHz 

Xenix R3.0upl 

cc 

1250 

1315 *16 

* Sequent Balance 8000 

NS32032-10 MHz 

Dynix2.0 

cc 

1250 

1315 N12 

* IBM PC/DSI-32 

32032-10 MHz 

MS-DOS 3-1 

Green Hills 2.14 

1282 

1315 C3 

* ATT 3B2/400 

WE32100-? MHz 

Unix 5.2 

cc 

1315 

1315 

* CCC 3250XP 

- 

Xelos R01(SVR2) 

cc 

1215 

1318 

* IBM PC RT 032 

RISC(801?)? MHz 

BSD 4.2 

cc 

1248 

1333 RT 

* DGMV4000 

- 

AOS/VS 5.00 

cc 

1333 

1333 

• IBM PC AT 

80286-8 MHz 

Venix/86 2.1 

cc 

1275 

1380 *16 

* IBM PC AT 

80286-6 MHz 

MS-DOS 3.0 

Microsoft 3.0 

1250 

1388 

* ATTPC6300+ 

80286-6 MHz 

MS-DOS 3.1 

CI-C86 2.20M 

1428 

1428 

* COMPAQ/286 

80286-8 MHz 

Venix/286 SVR2 

cc 

1326 

1443 

* IBM PC AT 

80286-7.5 MHz 

Venix/286 SVR2 

cc 

1333 

1449 *15 

* WICATPB 

68000-8 MHz 

System V 

WICATC 4.1 

1169 

1464 S 

* Tandy 11/6000 

68000-8 MHz 

Xenix 3.0 

cc 

1384 

1477 

* MicroVAX II 

- 

Mach/4.3 

cc 

1513 

1536 

* WICATMB 

68000-12.5 MHz 

System V 

WICATC 4.1 

1246 

1537 

* IBM PC AT 

80286-9 MHz 

SCO Xenix V 

cc 

1540 

1556 *18 

* CybDataMate 

68010-12.5 MHz 

Uniplus 5.0 

Unisoft cc 

1470 

1562 S 

* VAX-11/780 

- 

Unix 5.2 

cc 

1515 

1562 

* MicroVAX-II 

- 

- 

- 

1562 

1612 

* VAX-780/MA780 


Mach/4.3 

cc 

1587 

1612 

* VAX-11/780 

- 

Unix 4.3bsd 

cc 

1646 

1662 

* Apollo DN660 

- 

AegisSR9/IX 

cc 3 • 12 

1666 

1666 

* ATT3B20 

- 

Unix 5.2 

cc 

1515 

1724 

* NEC PC-98XA 

80286-8 MHz 

PC-DOS 3.1 

Lattice 2.15 

1724 

1724 % 

* HP9000-500 

B series CPU 

HP-UX 4.02 

cc 

1724 

- 

* Ridge 32C VI 

- 

ROS3-3 

Ridge C(older) 

1776 

- 

* IBM PC/STD 

80286-8 MHz 

MS-DOS 3.0 

Microsoft 3.0 

1724 

1785 C2 

* WICATMB 

68000-12.5 MHz 

System V 

WICATC 4.1 

1450 

1814 S 

* WICATPB 

68000-12.5 MHz 

System V 

WICATC 4.1 

1530 

1898 

* DEC-2065 

KLIO-ModelB 

TOPS-20 6.1FT5 

Port.C Comp. 

1937 

1946 

* Gould PN6005 

- 

UTX1.1(4.1BSD) 

cc 

1675 

1964 

* DEC2060 

KL-10 

T0PS-20 

cc 

2000 

2000 NM 

* Intel 310AP 

80286-8 MHz 

Xenix 3.0 

cc 

1893 

2009 

* VAX-11/785 

- 

Unix 5.2 

cc 

2083 

2083 

^ VAX-11/785 

- 

VMS 

VAX-11C2.0 

2083 

2083 

* VAX-11/785 

- 

Unix SVR2 

cc 

2123 

2083 

* VAX-11/785 

- 

ULTRIX-32 1.1 

cc 

2083 

2091 

* VAX-11/785 

- 

Unix 4.3bsd 

cc 

2135 

2136 

* WICATPB 

68000-12.5 MHz 

System V 

WICATC 4.1 

1780 

2233S 

* Pyramid 90x 

- 

OSx 2.3 

cc 

2272 

2272 

* Pyramid 90x 

FPA,cache,4Mb 

OSx 2.5 

cc no -O 

2777 

2777 

* Pyramid 90x 

w/cache 

OSx 2.5 

cc v/-0 

3333 

3333 

* IBM-4341-11 

- 

VM/SP3 

WaterlooC 1.2 

3333 

3333 

* IRIS-2400T 

68020-16.67 MHz 

Unix System V 

cc 

3105 

3401 

* Celerity C-1200 

? 

Unix 4.2BSD 

cc 

3485 

3468 

* SUN 3/75 

68020-16.67 MHz 

SUN 4.2 V3 

cc 

3333 

3571 

* IBM-4341 

Model 12 

UTS 5.0 

? 

3685 

3685 

* SUN 3/160 

68020-16.67 MHz 

Sun 4.2 V3.0A 

cc 

3381 

3764 

* Sun 3/180 

68020-16.67 MHz 

Sun 4.2 

cc 

3333 

3846 

* IBM-4341 

Model 12 

UTS 5.0 

? 

3910 

3910 MN 

* MC 5400 

68020-16.67 MHz 

RTU V3.0 

cc (V4.0) 

3952 

4054 

# Intel 386/20 

80386-12.5 MHz 

PMON debugger 

Intel C386v0.2 

4149 

4386 

* NCR Tower32 

68020-16.67 MHz 

SYS 5.0 Rel 2.0 

cc 

3846 

4545 

* MC 5600/5700 

68020-16.67 MHz 

RTU V3.0 

cc (V4.0) 

4504 

4746 % 

* Intel 386/20 

80386-12.5 MHz 

PMON debugger 

Intel C386v0.2 

4534 

4794 11 

* Intel 386/20 

80386-16 MHz 

PMON debugger 

Intel C386v0.2 

5304 

5607 

* Gould PN9080 

custom ECL 

UTX-32 1.1C 

cc 

5369 

5676 

^ Gould 1460-342 

ECL proc 

UTX/32 1.1/c 

cc 

5342 

5677 G1 

it VAX-784 

- 

Mach/4.3 

cc 

5882 

5882 &4 

it Intel 386/20 

80386-16 MHz 

PMON debugger 

Intel C386v0.2 

5801 

6133 il 

it VAX 8600 

- 

Unix 4.3bsd 

cc 

7024 

7088 

it VAX 8600 

- 

VMS 

VAX-11C2.0 

7142 

7142 

it Alliant FX/8 

CE ' 

Concentrix 

cc -cejexec -c 

6952 

7655 FX 

it CCI POWER 6/32 


COS(SV+4.2) 

cc 

7500 

7800 

♦t CCI POWER 6/32 


POWER 6 Unix/V 

cc 

8236 

8498 

* CCI POWER 6/32 


4.2 Rel. 1.2b 

cc 

8963 

9544 

* Sperry (CCI Power 6) 


4.2BSD 

cc 

9345 

10,000 

* CRAY-X-MP/12 

105 MHz 

COS 1.14 

Cray C 

10,204 

10,204 
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ft 

IBM-3083 

- 

UTS 5.0 Rel 1 

cc 

16,666 

12,500 

ft 

CRAY-1A 

80 MHz 

CTSS 

CrayC 2.0 

12,100 

13,888 

ft 

IBM-3083 

- 

VM/CMS HPO 3-4 

Waterloo C1.2 

13,889 

13,889 

ft 

Amdahl 470 V/8 


UTS/V5.2 

cc vl.23 

15,560 

15,560 

ft 

CRAY-X-MP/48 

105 MHz 

CTSS 

CrayC2.0 

15,625 

17,857 

ft 

Amdahl 580 

- 

UTS 5.0 Rel 1.2 

cc vl.5 

23,076 

23,076 

ft 

ft 

ft 

Amdahl 5860 

NOTE 


UTS/V5.2 

cc vl.23 

28,970 

28,970 


ft 

ft 

ft 

* 

ft 

ft 

ft 

ft 

ft 

* 

ft 

ft 

» 

* 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft 

ft— 

ft 

ft 

ft 

ft 

ft 

ft 

« 

ft 

ft 

ft 

ft 

ft 

ft 

x 

ft 

ft 

ft 

»/ 


ft 

+ 

% 

NM 

@ 

S 

T 

LM 

MM 

Cl 

C 2 

C3 

C? 

CT1 

MN 

G1 

FH 

FX 

RT 

il 


Nnn 

&nn 


Crystal changed from 'stock' to listed value. 

This Macintosh was upgraded from 128K to 512K in such a way that the new 384K of memory is not slowed down by video 
generator accesses. 

Single processor; MC == MASSCOMP. 

A version 7 C compiler written at New Mexico Tech. 

Vanilla Lattice compiler used with MicroPro standard library. 

Shorts used instead of ints. 

With Chris Torek' s patches (whatever they are). 

For WICAT Systems: MB=MultiBus, PB=Proprietary Bus. 

Large Memory Model. (Otherwise, all 80x8x results are small model). 

Medium Memory Model. (Otherwise, all 80x8x results are small model). 

Univation PC TURBO Coprocessor; 9.54-MHz 8086, 640K RAM 
Seattle Telecom STD-286 board. 

Definicon DSI-32 coprocessor. 

Unknown coprocessor board. 

Convergent Technologies MegaFrame, 1 processor. 

Using Mike Newton's 'optimizer' (see net.sources). 

This Gould machine has two processors and was able to run two Dhrystone benchmarks in parallel with 
no slowdown. 

FHC == Frank Hogg Labs (Hazelwood Uniquad 2 in an FHL box). 

The Alliant FX/8 is a system consisting of 1-8 CEs (computation engines) and 1-12 IPs (interactive processors). Note 
N8 applies. 

This is one of the RTs that CMU has been using for awhile. I'm not sure that this is identical to the machine that IBM is 
selling to the public. 

Normally, the 386/20 starter kit has a 16K direct-mapped cache, which inserts two or three wait states on a write- 
through. These results were obtained by disabling the write-through, or essentially turning the cache into 
zero-wait-state memory. 

This machine has multiple processors, allowing "nn" copies of the benchmark to run in the same time as one copy. 

This machine has "nn" processors, and the benchmark results were obtained by having all "nn" processors working on one 
copy of Dhrystone. (Note this is different than Nnn. Salesmen like this measure.) 

I don't trust results marked with ' ?'. These were sent to me with either incomplete info, or with times that Just don't 
make sense. ?? means I think the performance is too poor; ?! means too good. If anybody can confirm these figures, 
please respond. 


ABBREVIATIONS 

CCC 

MC 


Concurrent Computer Corp. (was Perkin-Elmer) 
Masscomp 


-RESULTS END - 


The following program contains statements of a high-level programming language (C) in a distribution 
considered representative: 

assignments 53JK 

control statements 32 % 

procedure, function calls 15!C 

100 statements are dynamically executed. The program is balanced with respect to the three aspects: 

- statement type 

- operand type (for simple data types) 

- operand access 

operand global, local, parameter, or constant. 

The combination of these three aspects is balanced only approximately. 

The program does not compute anything meaningful, but it is syntactically and semantically correct. 


/# Accuracy of timings and human fatigue controlled by next two lines */ 

^define LOOPS 50000 /# Use this for slow or 16-bit machines #/ 

/*#define LOOPS 500000 /# Use this for faster machines #/ 


continued 
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/* Compiler-dependent options */ 

tfundef NOENUM /* Define if compiler has no enums */ 

tfundef NOSTRUCTASSIGN /* Define if compiler can't assign structures */ 

/# define only one of the next two defines #/ 

I *#define TIMES /* Use times(2) time function #/ 

^define TIME /* Use time(2) time function #/ 


/* define the granularity of your times(2) function (when used) #/ 

^define HZ 60 /* times(2) returns 1/60 second (most) */ 

/*#define HZ 100 /* times(2) returns 1/100 second (WECo) #/ 


/* for compatibility with goofed-up version */ 

/x#define GOOF /* Define if you want the goofed-up version */ 

tfifdef GOOF 

char Vers ion [ ] * "1.0"; 

0else 

char Vers ion [ ] = "1.1"; 

#endif 


tfifdef 

NOSTRUCTASSIGN 

^define 

structassign(d, s) 

0else 



^define 

structassign(d, s) 

tfendif 



0ifdef 

NOENUM 


^define 

Identl 

1 

^define 

Ident2 

2 

^define 

Ident3 

3 

^define 

Ident4 

4 

^define 

Identl 

5 

typedef 

tfelse 

int 

Enumeration; 

typedef 

rfendif 

enum 

{Identl, Ident2 


memcpy(&(d), &(s), sizeof(d)) 
d = s 


Ident3, Ident4, Ident5} Enumeration; 


typedef 

int 

OneToThirty; 

typedef 

int 

OneToFifty; 

typedef 

char 

CapitalLetter; 

typedef 

char 

String30[31]; 

typedef 

int 

ArraylDim[51]; 

typedef 

int 

Array2Dim[51][51]; 

struct 

Record 


{ 

struct Record 

Enumeration 

Enumeration 

OneToFifty 

String30 

}; 

typedef struct Record RecordType; 
typedef RecordType # RecordPtr; 
typedef int boolean; 

/* #deflne NULL 0*1 

^define TRUE 1 

^define FALSE 0 


*PtrComp; 

Discr; 

EnumComp; 

IntComp; 

StringComp; 


#ifndef REG 
^define REG 
rt/endif 

extern Enumeration Funcl(); 
extern boolean Func2(); 


0include <HD20:C:^include files: stdio.h> 

0ifdef TIMES 

^include <HD20:C:#include files:unix ^includes: types.h> 
^include <HD20:C:#include files:unix ^includes: time.h> 
0endif 
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main() 

{ 

ProcO(); 
exit(O); 

} 


1* 


* Package 1 


»/ 


int 

IntGlob; 

boolean 

BoolGlob; 

char 

CharlGlob; 

char 

Char2Glob; 

ArraylDim 

ArrayIGlob; 

Array2Dim 

Array2Glob; 

RecordPtr 

PtrGlb; 

RecordPtr 

PtrGlbNext; 

Proc0() 



{ 

OneToFifty 
REG OneToFifty 
OneToFifty 
REG char 
REG char 
Enumeration 
String30 
String30 
extern char 

tfifdef TIME 

long 

long 

long 

long 

register unsigned int 


IntLocl; 
IntLoc2; 
IntLoc3; 
CharLoc; 
CharIndex; 
EnumLoc; 
StringlLoc; 
String2Loc; 
#malloc(); 


time(); 

starttime; 

benchtime; 

nulltime; 

l; 


starttime=time( (long*)0); 
for (i = 0; i< LOOPS;++i); 

nulltime = time( (long #) 0) - starttime; /# Computes o'head of loop #/ 

tfendif 
0ifdef TIMES 

time_t 
time_t 
time_t 
struct tm 

register unsigned int 


starttime; 

benchtime; 

nulltime; 

tms; 

i; 


times(&tms); starttime = tms.tms_utime; 
for (i = 0; i< LOOPS; ++i); 
times(&tms); 

nulltime = tms.tms_utime - starttime; /# Computes overhead of looping #/ 

tfendif 


PtrGlbNext = (RecordPtr) malloc(sizeof(RecordType)); 

PtrGlb = (RecordPtr) malloc(sizeof(RecordType)); 
PtrGlb->PtrComp » PtrGlbNext; 

PtrGlb->Discr= Identl; 

PtrGlb->EnumComp = Ident3; 

PtrGlb->IntComp = 40; 

s trcpy (PtrGlb->StringComp, "DHRYSTONE PROGRAM, SOME STRING"); 

^ifndef GOOF 

strcpy(StringlLoc, "DHRYSTONE PROGRAM, 1ST STRING"); /#G00F#/ 

*endif 

Array2Glob[8] [7] = 10; /# Was missing in published program */ 

/ft******************* 

— Start Timer — 

########/ 

0ifdef TIME 

starttime »time( (long #) 0); 

He ndif 
tflfdef TIMES 

times(&tms); starttime = tms.tms_utime; 


continued 
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#endif 

for (i = 0; i< LOOPS; ++1) 

{ 


Proc5(); 

Proc4(); 

IntLocl=2; 

IntLoc2 = 3; 

strcpy (String2Loc, "DHRYSTONE PROGRAM, 2ND STRING"); 
EnumLoc = Ident2; 

BoolGlob = ! Func2(StringlLoc, String2Loc); 
while (IntLocl < IntLoc2) 

{ 

IntLoc3 * 5 * IntLocl - IntLoc2; 

Proc7(IntLocl, IntLoc2, &IntLoc3); 

•H-IntLocl; 

} 

Proc8(ArrayIGlob, Array2Glob, IntLocl, IntLoc3); 
Procl(PtrGlb); 

for (Charlndex = 'A'; Charlndex<= Char2Glob; ++Charlndex) 
if (EnumLoc == Fund(Charlndex, *C *)) 
Proc6(Identl, &EnumLoc); 

IntLoc3 = IntLoc2 # IntLocl; 

IntLoc2 = IntLoc3 / IntLocl; 

IntLoc2 = 7 # (IntLoc3 - IntLoc2) - IntLocl; 
Proc2(&IntLocl); 


/ - 

Stop Timer 

- / 


/Hifdef TIME 

benchtime =» time( (long *) 0) - starttime - nulltime; 
printf("Dhrystone(Jts) time for *ld passes -%l\ n", 

Version, 

(long) LOOPS, benchtime); 

printf ("This machine benchmarks at Xld Dhrystones/second \ n", 
((long) LOOPS) / benchtime); 

0endif 
/Kifdef TIMES 

times(&tms); 

benchtime = tms.tms_utime - starttime - nulltime; 
printf("Dhrystone(*s) time for %ld passes * *ld\ n", 

Version, 

(long) LOOPS, benchtime/HZ); 

printf ("This machine benchmarks at *ld Dhrystones/second \ n", 
((long) LOOPS) * HZ / benchtime); 

tfendif 

} 

Procl(PtrParln) 

REG RecordPtr PtrParln; 

{ 

0defineNextRecord (#(PtrParIn->PtrComp)) 

structassign(NextRecord, *PtrGlb); 

PtrParIn->IntComp = 5; 

NextRecord.IntComp = PtrParIn->IntComp; 

NextRecord.PtrComp = PtrParIn->PtrComp; 

Proc3(NextRecord.PtrComp); 
if (NextRecord.Discr « Identl) 

{ 

NextRecord.IntComp = 6; 

Proc6(PtrParIn->EnumComp, &NextRecord.EnumComp); 
NextRecord.PtrComp = PtrGlb->PtrComp; 

Proc7(NextRecord.IntComp, 10, &NextRecord.IntComp); 

} 

else 

structassign(#PtrParIn, NextRecord); 


0undef NextRecord 

} 
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Rroc2(IntParI0) 

OneToFifty •IntParlO; 

{ 

REG OneToFifty IntLoc; 

REG Enumeration EnumLoc; 


IntLoc = *IntParIO + 10; 
for(;;) 

{ 

If (CharlGlob == 'A') 

{ 


—IntLoc; 

•IntParlO =IntLoc - IntGlob; 
EnumLoc = Identl; 

} 

if (EnumLoc == Identl) 


break; 

} 

} 


Proc3(PtrPar0ut) 

RecordPtr #PtrParOut; 

{ 

If (PtrGlb ! = NULL) 

•PtrParOut = PtrGlb->PtrComp; 

else 

IntGlob = 100; 

Proc7(l0, IntGlob, &PtrGlb->IntComp); 

} 

Proc4() 

{ 

REG boolean BoolLoc; 

BoolLoc = CharlGlob == 'A'; 

BoolLoc | = BoolGlob; 

Char2Glob = 'B'; 

} 


Proc5() 

{ 

CharlGlob = 'A'; 
BoolGlob = FALSE; 

} 

extern boolean Func3(); 


Proc6(EnumParIn, EnumParOut) 
REG Enumeration EnumParIn; 
REG Enumeration •EnumParOut; 

{ 


} 


•EnumParOut * EnumParln; 
if (! Func3(EnumParln) ) 

•EnumParOut = Ident4; 
switch (EnumParln) 

{ 


case Identl: 
case Ident2: 


case Ident3: 
case Ident4: 
case Ident5: 
} 


•EnumParOut * Identl; break; 
if (IntGlob > 100) •EnumParOut * Identl; 
else •EnumParOut = Ident4; 
break; 

•EnumParOut * Ident2; break; 
break; 

•EnumParOut = Ident3; 


Proc7(IntParIl, IntParI2, IntParOut) 

OneToFifty IntParll; 

OneToFifty IntParI2; 

OneToFifty •IntParOut; 

{ 

REG OneToFifty IntLoc; 


IntLoc = IntParll+ 2; 

• IntParOut * IntParI2 + IntLoc; 


continued 


BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 21 




July 


} 

Proc8(ArrayIPar, Array2Par, IntParll, IntParI2) 

ArrayIDim ArraylPar; 

Array2Dim Array2Par; 

OneToFifty IntParll; 

OneToFifty IntParI2; 

{ 

REG OneToFifty IntLoc; 

REG OneToFifty IntIndex; 

IntLoc = IntParll + 5; 

ArraylPar[IntLoc] =IntParI2; 

ArraylPar[IntLoc+1] = ArraylPar[IntLoc]; 

ArraylPar[IntLoc+30] =IntLoc; 

for (Intlndex = IntLoc; Intlndex<= (IntLoc+1); ++Intlndex) 
Array2Par[IntLoc][IntIndex] =IntLoc; 

++Array2Par[IntLoc][IntLoc-1]; 

Array2Par[IntLoc+20][IntLoc] = ArraylPar[IntLoc]; 

IntGlob = 5; 

} 

Enumeration Fund (Char Pari, CharPar2) 

CapitalLetter CharParl; 

CapitalLetter CharPar2; 

{ 

REG CapitalLetter CharLocl; 

REG CapitalLetter CharLoc2; 


} 


CharLocl= CharParl; 
CharLoc2 = CharLocl; 
if (CharLoc2 != CharPar2) 
return (Identl); 

else 

return (Ident2); 


boolean Func2(StrParIl, StrParI2) 

String30 StrParll; 

String30 StrParI2; 

{ 

REG OneToThirty IntLoc; 

REG CapitalLetter CharLoc; 


} 


IntLoc = 1; 
while (IntLoc<= 1) 

if (Funcl(StrParIl[IntLoc], StrParI2[IntLoc+1]) == Identl) 

{ 

CharLoc « 'A'; 

++IntLoc; 

} 

if (CharLoc >- 'W* && CharLoc <» 'Z') 

IntLoc = 7; 
if (CharLoc == 'X') 
return(TRUE); 

else 

{ 

if (strcmp(StrParIl, StrParI2) > 0) 

{ 

IntLoc += 7; 
return (TRUE); 

} 

else 


} 


return (FALSE); 


boolean Func3(EnumParIn) 

REG Enumeration EnumParln; 

{ 

REG Enumeration EnumLoc; 


EnumLoc = EnumParln; 

if (EnumLoc »■ Ident3) return (TRUE); 

return (FALSE); 
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H ifde f NOSTRUCTASSIGN 

rnemcpy(d, s, 1) 

register char 

*d; 

register char 

*s; 

register int 

{ 

while 

} 

l; 

(1—) *d++ 


tfendif 


FIB.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


^include <stdio.h> 

^define NTIMES 10/* number of times to compute Fibonacci value */ 
^define NUMBER 24/* biggest one we can compute with 16 bits */ 

main() 

/* compute Fibonacci value */ 

{ 

int i; 

unsigned value, fib(); 

printf("*d iterations: ", NTIMES); 

for (i ■ 1; i<= NTIMES; i++) 
value = fib(NUMBER); 

printf( "Fibonacci Jd) = j(u.\n", NUMBER, value); 
exit(0); 

} 


unsigned fib(x) 

/* compute Fibonacci number recursively */ 


int x; 

{ 

if (x > 2) 

return (fib(x - 1) + fib(x - 2)); 


else 

return (1); 

} 


FLOAT.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


/* simple benchmark for testing floating-point speed of c libraries 
does repeated multiplications and divisions in a loop that is 
large enough to make the looping time insignificant */ 

^define C0NST1 3-141597E0 
^define C0NST2 1.7839032E4 
^define COUNT 10000 

main() 

{ 

double a, b, c; 
int i; 

a = C0NST1; 
b * C0NST2; 

for (i ■ 0; i< COUNT; ++i) 

{ 

c = a * b; 

continued 

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 23 









July 


c * c/ a; 
c = a * b; 
c = c/ a; 
c = a # b; 
c ■ c/ a; 
c = a * b; 
c = c/a; 
c = a * b; 
c = c/ a; 
c = a*b; 
c = c/ a; 
c = a # b; 
c = c/a; 

} 

printf ("Done\n"); 

} 


SORT.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


/# sorting benchmark- -calls randomly the number of times specified by 
MAXNUM to create an array of long integers, then does a quicksort 
on the array of longs. The program does this for the number of 
times specified by COUNT. 

*/ 

^include "stdlo.h" 

^define MAXNUM 1000 
^define COUNT 10 

^define MODULUS ((long) 0x20000) 

^defineC13849L 
^define A25173L 

long seed = 7L; 

long random (); 

long buffer [MAXNUM] = {0}; 

main() 

{ 

int i, J; 
long temp; 

/* 

^include "startup.c" 

*/ 

printf ("Filling array and sorting %6 times\n", COUNT); 
for (i = 0; i< COUNT; ++i) 

{ 

for (J =0; J < MAXNUM; ++J) 

{ 

temp = random (MODULUS); 
if (temp< 0L) 

temp = (-temp); 
buffer[J] = temp; 

} 

printf ("Buffer full, iteration Jfd\n", i); 
quick (0, MAXNUM - 1, buffer); 

} 

/» 

^include "done.c" 

*/ 

} 

quick (lo, hi, base) 
int lo, hi; 
long base [ ]; 

{ 
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int i, j; 

long pivot, temp; 
if (lo< hi) 

for (i = lo, j = hi-1, pivot = base [hi]; i < j; ) 

{ 

while (i < hi && base [i] <= pivot) 

•f+i; 

while (j > lo && base [j ] >= pivot) 

J i 

if (i<J) 

{ 

temp = base [i]; 
base [i] = base [j]; 
base [j] = temp; 

} 

} 

temp = base [i]; 
base [i] = base [hi]; 
base [hi] = temp; 
quick (lo, i - 1, base); 
quick (i + 1, hi, base); 

} 

} 

long random (size) 
long size; 

{ 

seed = seed * A + C; 
return (seed % size); 

) 


SIEVE.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


/* 

Eratosthenes Sieve prime-number program in from BYTE January 1983 
*/ 

^define TRUE 1 
^define FALSE 0 
^define size 8190 


char flags [size + 1]; 
main() 

{ 

int i, prime, k, count, iter; 


} 


printf ("10 iterations\n"); 
for (iter = 1; iter<= 10; iter++) 
{ 

count * 0; 

for (1 = 0; i < = size; i++) 
flags [i] = TRUE; 
for (i = 0; i <= size; i++) 


/# do program 10 times #/ 

/# prime counter #/ 

/# set all flags true #/ 


{ 

if (flags [i]) /« found a prime #/ 

{ 

prime = i + i + 3# /# twice index + 3 *1 

I* printf ("\n*d", prime); */ 
for (k»i + prime; k<= size; k+= prime) 

flags [k] = FALSE; /# kill all multiple #/ 

count-H*; I* primes found */ 

} 


} 

printf ("tfd primes.\n", count); /# primes found on 10th pass #/ 
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SAVAGE.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


/* 

** savage.c — floating-point speed and accuracy test. C version 
** derived from BASIC version that appeared in Dr. Dobb's Journal, 
** Sept. 1983, pp. 120-122. 

*/ 


^define 

I LOOP 

2500 

extern 

double 

main() 

{ 

int i; 

tan(), atan(), exp(), log(), sqrt(); 

double a; 

printf("start\n"); 
a = 1.0; 

for (i«l; i<= (IL00P-1); i++) 
a = tan(atan(exp(log(sqrt(a#a)))))+1.0; 
printf("a = *20.l4e\n", a); 
printf("done\n"); 


} 


FILEIO.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


/# file reading and writing benchmark 

sequentially writes a 65,000-byte file on disk 
generates random long numbers 

uses these modulo 65,000 to read and write strings of 0DDNUM bytes 
with the file-handling system of the c package 
the random-number generator is set to a specific seed, 
so that all compilers should generate the same code 

*/ 

^define ERROR -1 
^define READERR 0 

^define BEG 0 
^define CURR 1 
^define END 2 
^define READ0 
/I/define WRITE 1 
^define UPDATE 2 

^define 0KCL0SE 0 
^define FILESIZE 65000L 
^define COUNT 500 

^defineC 13849L 
^define A 25173L 
^define 0DDNUM 23 
long seed * 7L; 

long random (), lseek (); 

main () 

{ 

int i; 

long J, pos; 
int fd; 

char buffer [0DDNUM + 1]; 
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if ((fd = creat ("test.dat", WRITE)) == ERROR) 
abort ("Can't create data file\n"); 
else printf ("File opened for sequential writing\n"); 
for (J = 0; j < FILESIZE; ++J) 

if (write(fd, "x", 1) == ERROR) 

abort ("Unexpected EOF in writing data file\n"); 
if (close (fd) ! = OKCLOSE) 

abort ("Error closing data file\n"); 

else 

printf ("Normal termination writing data file\n"); 
if ((fd = open ("test.dat", UPDATE)) == ERROR) 

abort ("Can't open data file for random reading and writing\n"); 
else printf ("File opened for random reading and writing\n"); 
for (i = 0; i< COUNT; ++i) 

{ 

J = random (FILESIZE); 
if (J < 0L) 

J =(-J); 

if (FILESIZE - j < ODDNUM) 
continue; 

if ((pos = lseek (fd, j, BEG)) == -1L) 

abort ("Error reading at random offset\n"); 
if (read (fd, buffer, ODDNUM) « READERR) 

abort ("Error reading at random offset\n"); 
j = random (FILESIZE); 
if (J < 0L) 

J = (-J); 

if (FILESIZE-J< ODDNUM) 
continue; 

if ((pos = lseek (fd, J, BEG)) « -1L) 

abort ("Error seeking to random offset\n"); 
if (write (fd, buffer, ODDNUM) == READERR) 

abort ("Error writing at random offset\n"); 

if (close (fd) != OKCLOSE) 

abort ("Error closing data file\n"); 

else 

printf ("Normal termination from random reading and writing\n"); 

long random (size) 
long size; 

{ 

seed = seed # A + C; 
return (seed % size); 

} 

abort (message) 
char ^message; 

{ 

printf (message); 
exit (ERROR); 

} 


WHET.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 


/* 

From hplabsIsdcrdcf!sdcsvax!dcdwest!ittatc!decvax!mcnc!rti-sel!scirtp!dfh 
Sun Aug 25 12:55:29 1985 

Relay-Version: version B 2.10.2 9/18/84; site amdahl.UUCP 

Pos t ing-Vers ion: vers ion B 2.10.2 9/ 5 / 84; s i te sc irtp. UUCP 

Path: amdahl!hplabsIsdcrdcf!sdcsvax1dcdwest1ittatc!decvax!mcnclrti-selIscirtp!dfh 
From: dfhgscirtp.UUCP (David F. Hinnant) 

Newsgroups: net.sources 

Subject: Whetstone benchmark source in C - enclosed 
Mcssage-ID:<353@scirtp.UUCP> 

Date: 25 Aug 85 19:55:29 GMT 

Date Received: 27 Aug 85 08:15:18 GMT 

Distribution: net 

Organization: SCI Systems, Research Triangle Park, NC 

Lines: 252 continued 
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Enclosed below is a C translation of the famous "Whetstone benchmark" 
from the original Algol version. I have inserted printf () as a 
compiler option. I think this translation is accurate. The only 

listing accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C 
language benchmarks used in BYTE reviews. 

Numbers I have to compare with are from an old Ridge-32 machine, and 
these are from a Pascal translation (I caught one error in their 
translation). If anyone has any numbers from FORTRAN, Pascal, or Algol 
versions of the Whetstone, I would very much like to see them. 

David Hinnant 
SCI Systems Inc. 

{decvax, akgua} !mcnc!rti-sel!scirtp!dfh 
P.S. There is a .signature file at the end of the listing. #/ 

11 ............ 

/* 

ft Whetstone benchmark in C. This program is a translation of the 
ft original Algol version in "A Synthetic Benchmark" by H. J. Curnow 
ft and B. A. Wichman in Computer Journal, vol. 19, no. 1, February 1976. 

* 

ft Used to test compiler optimization and floating-point performance. 

ft 

* Compile by: cc-0-s-o whet whet.c 
ft or: cc -0 -DP0UT -s -o whet whet. c 
ft if output is desired. 

»/ 

^define ITERATIONS 10 /* 1 million Whetstone instructions */ 

#include "sane.h" 

^include "stdio.h" 

II ^Options G H 

^define POUT 

^define Pout(n, J, k, xl, x2, x3, x4) timingOff;\ 
pout(n, j, k, xl, x2, x3, x4);timing0n 
#def ine double extended 
^define tickCount #((long #)0xl6A) 

^define timingOn ticks -* tickCount 
^define timingOff ticks += tickCount 

double xxl, xx2, xx3, xx4, x, y, z, t, tl, t2; 
double el[4]; 

int i, J, k, 1, nl, n2, n3, n4, n6, n7, n8, n9, nlO, nil; 
long ticks; 

main() 

{ 

printf("\nWhetstone Benchmark\n\n"); 

ticks * 0; 

timingOn; 

/# initialize constants #/ 

t *0.499975; 
tl* 0.50025; 
t2 * 2.0; 

I* set values of module weights #/ 

nl*0# ITERATIONS; 
n2 * 12 # ITERATIONS; 
n3 a 14 # ITERATIONS; 
n4 * 345 * ITERATIONS; 
n6* 210 * ITERATIONS; 
n7 * 32 # ITERATIONS; 
n8 * 899 » ITERATIONS; 
n9 - 616 # ITERATIONS; 
nlO * 0 # ITERATIONS; 
nil * 93 * ITERATIONS; 

/# MODULE 1: simple identifiers #/ 
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xxl=1.0; 

xx2 = xx3 = xx4 = -1.0; 


for(i = 1; i<= nl; i+= 1) { 
xxl = ( xxl + xx2 + xx3 - xx4 ) # t; 
xx2 = ( xxl + xx2 - xx3 - xx4 ) * t; 
xx3 = ( xxl - xx2 + xx3 + xx4 ) * t; 
xx4 = (-xxl + xx2 + xx3 + xx4 ) # t; 

} 

0ifdef POUT 

Pout(nl, nl, nl, xxl, xx2, xx3, xx4); 
tfendif 

/# MODULE 2: array elements #/ 
el[0] =1.0; 

el[l] = el[2] = el[3] =-1.0; 

for (1 = 1; i <= n2; i+=1) { 
el[0] = ( el[0] + el[l] + el[2] - el[3] ) * t; 
el[l] = ( el[0] + el[l] - el[2] + el[3] ) * t; 
el[2] = ( el[0] - el[l] + el[2] + el[3] ) * t; 
el[3] = (-el[0] + el[l] + el[2] + el[3] ) * t; 

#ifdef POUT 

Pout(n2, n3, n2, el[0], el[l], el[2], el[3]); 
tfendif 

/# MODULE 3: array as parameter #/ 

for (1 = 1; 1 <= n3; i+= 1) 
pa(el); 

#ifdef POUT 

Pout(n3, n2, n2, el[0], el[l], el[2], el[3]); 
tfendif 

/# MODULE 4: conditional Jumps #/ 


J = i; 

for (1 = 1; 1 <= n4; 1 += 1) { 

if (J a =D 

J = 2; 
else 
JOl 

if (J>2) 

J = 0; 
else 

J a 1; 

if (J <1) 

J -l; 

else 
J = 0; 

} 

#ifdef POUT 

Pout(n4, J, J, xxl, xx2, xx3, xx4); 
^endif 

/* MODULE 5: omitted */ 

/# MODULE 6: integer arithmetic #/ 


J = i; 
k = 2; 
1-3; 


for (i = 1; i <= n6; i += 1) { 

J s J # (k-J) * (1-k); 

k = l*k-(l-J) *k; 
l.(l-k)»(k + J); 

el[l - 2] ■ J + k + 1; /# C arrays are zero-based */ 

el[k - 2] = J * k * 1; 

} 


continued 
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tfifdef POUT 

Pout(n6, J, k, el[0], el[l], el[2], el[3]); 
#endif 

/# MODULE 7: trig, functions */ 
x = y = 0.5; 


for(i = 1; i <= n7; i+=l) { 

x = t * atan(t2*sin(x)*cos(x)/(cos(x+y)+cos(x-y)-1.0)); 
y = t * atan(t2#sin(y)*cos(y)/(cos(x+y)+cos(x-y)-l*0)); 

} 

#ifdef POUT 

Pout(n7, J > k> x, x, y, y); 

0endif 

/# MODULE 8: procedure calls #/ 

x = y = z = 1.0; 

for (1*1; i<=n8; i+=l) 

P3(x, y, &z); 
tfifdef POUT 

Pout(n8, J, k, x, y, z, z); 

0endif 

/# MODULE 9: array references */ 

J -U 

k = 2; 

1*3? 


el[0] =1.0; 
el[l] =2.0; 
el[2] =3.0; 

for(i = 1; i <= n9; i+= 1) 

POO? 

#ifdef POUT 

Pout(n9, J, k, el[0], el[l], el[2], el[3]); 
0endif 

/# MODULE 10: integer arithmetic #/ 

J =2; 
k = 3? 


for(i = 1; i<= nlO; i +=1) { 

J = J + k; 
k = J +k; 

J *k- J; 
k = k-J - J; 

} 

#lfdef POUT 

Pout(nlO, j, k, xxl, xx2, xx3> xx4); 

0endif 

/# MODULE 11: standard functions #/ 
x * 0.75; 

for(i = 1; i <= nil; i+=l) 
x = sqrt( exp( log(x) / tl)); 

#ifdef POUT 

Pout(nll, J, k, x, x, x, x); 
tfendif 

timingOFF; 

printf("\nWhetstone runs in *0.2f seconds. #0.2f whets/second\n" 
tlcks/60.0, 60000000.0/ticks); 
getchar(); 
exit(O); 


} 
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pa(e) 

double e[4]; 

{ 

register int j; 

J =0; 
lab: 

e[0] . ( e[0] + e[l] + e[2] - e[3J ) * t; 

e[l] ' ( e[0] + e[l] - e[2] + e[3] ) * t; 

e[2] = ( e[0] - e[l] + e[2] + e[3] ) * t; 

e[3] = ( -e[0] +e[l] +e[2] +e[3] ) /12; 

J +»1; 
if (J < 6) 

goto lab; 


P3(x, y, z) 
double x, y, *z; 

{ 

x = t* (x + y); 
y = t* (x + y); 
»z = (x + y) /t2; 

} 

POO 

{ 

el[J] -el[k); 
el[k] «el[l]j 
el[l] ■ el[J]; 

} 


#ifdefPOUT 

pout(n, J, k, xl, x2, x3, x4) 

int n, j, k; 

double xl, x2, x3, x4; 

{ 

printf ("*5d *5d *11.3e *11.Je tll.Je *11.3e\n", 

n, J, k, xl, x2, x3, x4); 

} 

tfendif 

/» 


David Hinnant 
SCI Systems Inc. 

{decvax, akgua} !mcnc!rti-sel!scirtp!dfh 


*/ 


USORT.PAS Program in Turbo Pascal 3*0 for the IBM PC and compatibles. From the article "Focus on Algorithms: Sorting out the Sorts" 
by Dick Pountain, July 1987, page 275. 


program USORT; 

const CR = H 13; { carriage return character } 

type letters = ' a'.. * z'; 
wordtype = string[l6]; 
nodeptr* "nodetype; 
nodetype = record 
info: wordtype; 
next: nodeptr 
end; 

var inputFile,outputFile: text; 

inputFilename, outputFilename: string[127]; 
chr,firstletter: char; 

sortList: array [letters] of nodeptr; { the array of 26 lists } 
i: letters; 
word: wordtype; 
procedure InitFiles; 
begin { open input and output files } 


continued 
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inputFilename := paramSTR(l); 

Assign(inputFlle,inputFilename); 

Reset(inputFile); 
outputFilename := paramSTR(2); 

Assign(outputFile, outputFilename); 

Rewrite(outputFile); 
end; 

procedure GetWord(VAR inFile: text; VAR word: wordtype); 
begin { read a cleaned-up word from the input file } 
word := ''; { initialize to blank } 

repeat 

read(infile,chr); 

if chr in [' A'.. *Z 1 ] { convert all to lowercase } 

thenchr : = char(ord(chr)+32); 

if chr in [ 1 a 1 .. * z' ] { only accept alpha characters } 

then word : = word+chr; { add to word being built} 
until (chr = ' ') or (chr = CR) or eof(infile) 
end; 

procedure Place (VAR list: nodeptr; word: wordtype); 
var p,q,newnode: nodeptr; 
found: boolean; 

begin { insert new word into list in sorted position only if unique } 
q : = nil; 

p:=list; { p points to head of list) 
found : = false; 

while (p<> nil) { not end of list and } 
and (not found) { word not already here and } 

and (word >= p*. info) do { word alphabetically later than current} 
if p*. info = word { does this node contain our word? } 
then found : = true { yes! word is already here ) 
else begin 

q : = p; { remember this node and } 
p : = p* .next { move on to the next one } 
end; {while} 

if not found { word isn' t already here } 
then begin 

New(newnode); { create a new node } 

newnode*. info : = word; { put word in its info field } 

ifq = nil { list was empty } 

then begin 

newnode* .next := list; { newnode becomes first} 
list := newnode 
end 

else begin 

newnode*.next :*q“.next; { insert after node q } 
q*.next := newnode 
end 
end 
end; 

procedure SquirtOut(list: nodeptr; VARoutflle: text); 
begin { send sorted list to output file } 
while list <> nil 
begin 

writeln(outfile,list*.info); 
list := list*.next 
end 
end; 

begin { main program } 

InitFiles; 

for i := 1 a' to 'z' do sortList[i] :« nil; { initialize all the lists } 

while not eof (inputFile) do 

begin 

GetWord(inputFile,word); 
firstletter :* word[l]; { get first letter } 

Place(sortList[firstletter] ,word) { put word in proper place } 
end; {while} 

fori := 'a' to 'z f doSquirtOut(sortList[i],outputFile); 
writeln('Keywords are contained in ',outputFilename); 

Close(inputFile); 

Close(outputFile) 

end. 
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LISTING2.TXT Contributed by David Gedeon. Accompanies "Programming Insight: Complex Math in Pascal," July 1987, page 121. 


{$INCLUDE:'complex.int'} 

IMPLEMENTATION OF complex; 

TYPE 

stackpt = "stack; 
stack = RECORD 

r, i: REAL; {Holds real and imaginary parts of number} 
next,prev: stackpt; {Links RECORDS of stack} 

END; 

VAR zpt,zroot: stackpt; {variable stack pointer and root position} 

PROCEDURE push; {increments stack pointer; creates new RECORD only if next position = NIL} 

VARzsav: stackpt; 

BEGIN 

IF (zpt".next <> NIL) THEN zpt:* zpt".next 
ELSE BEGIN 
zsav:= zpt; 

NEW(zpt); 

zpt" .prev:= zsav; zpt".next:* NIL; 
zsav" .next:= zpt; 

END; 

END; 

PROCEDURE pop; {Decrements stack pointer} 

BEGIN 

IF (zpt".prev<> NIL) THEN zpt:= zpt".prev 
ELSE BEGIN {In case of no previous element, pop zeros} 
zpt".r:=0.0; zpt".i:=0.0; 

END; 

END; 

FUNCTION display: {Argument (indx: INTEGER) declared in interface; extracts real or imaginary parts of current stack pointee} 
BEGIN 

CASE indx OF 
1: display:= zpt".r; 

2: display:= zpt".i; 

OTHERWISE display:* 0; 

END; 

END; 

PROCEDURE keyin; {Argument (z: cmplx) declared in interface; equivalent of keying in numbers on calculator; pushes stack, 
inserts number at new pointee} 

BEGIN 

push; 

zpt".r:= z[l]; 
zpt".i:* z[2]j 

END; 

PROCEDURE rkeyin; {Argument (x: REAL) declared in interface} 

{Similar to KEYIN except enters real number} 

BEGIN 

push; 

zpt".r:* x; 
zpt".i:* 0.0; 

END; 

PROCEDURE enter; {Copies current pointee onto stack} 

VAR a,b: REAL; 

BEGIN 

a:* zpt".r; b:= zpt".i; 
push; 

zpt".r:=a; zpt".i:*b; 

END; 


continued 
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PROCEDURE clear; {Resets stack pointer to root of list, zeros} 

BEGIN 

zpt:= zroot; 

zpt A .r:=0.0; zpt A .i: = 0.0; 

END; 

PROCEDURE negate; {Negative of current stack polntee} 

BEGIN 

zpt" .r: = -zpt A .r; 
zpt A .i:= -zpt A .i; 

END; 

PROCEDURE conjugate; {Complex conjugate of current stack pointee} 

BEGIN 

zpt A .i:» - zpt A .i; 

END; 

PROCEDURE invert; {inverse of current stack pointee} 

VAR mag: REAL; 

BEGIN 

mag: = (zpt A .r * zpt A .r) + (zpt A .i * zpt A .i); 
zpt A .r:= zpt A .r/ mag; 
zpt A . i:= -zpt A . i / mag; 

END; 

PROCEDURE add; {Adds current and previous stack pointees; pops stack; result in new pointee} 
VAR a,b: REAL; 

BEGIN 

a: = zpt A .r; b: = zpt A .i; 
pop; 

zpt A .r:= zpt A .r + a; 
zpt A .i:« zpt A .i+ b; 

END; 


PROCEDURE subtract; {Subtracts current from previous stack pointee; pops stack; result in new pointee} 
BEGIN 
negate; 
add; 

END; 

PROCEDURE multiply; {Multiplies current and previous stack pointees; pops stack; result in new pointee} 
VAR a,b,c,d: REAL; 

BEGIN 

a: = zpt A .r; b:= zpt A .i; 
pop; 

c:= (a # zpt A .r) - (b # zpt A .i); 
d:= (a # zpt A .i) + (b * zpt A .r); 
zpt A .r:= c; 
zpt A .i:=d; 

END; 

PROCEDURE divide; {Divides previous stack pointee by current; pops stack; result in new pointee} 

BEGIN 

invert; 

multiply; 

END; 

PROCEDURE cexp; {Complex exponential function of current stack pointee} 

VAR mag: REAL; 

BEGIN 

mag:= EXP(zpt A .r); 

zpt*.r: * mag#COS(zpt A . i); 

zpt A . i: = mag#SIN( zpt A . i); 

END; 

PROCEDURE sinh; {Complex hyperbolic sine of current stack pointee} 

VARz: cmplx; 

BEGIN 

z[l] :■ zpt A .r; z[2] := zpt A .i; 
cexp; 

keyin(z); negate; cexp; subtract; 
zpt A .r:» 0.5*zpt A .r; zpt A .i:«0.5#zpt A .i; 

END; 
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PROCEDURE cosh; {Complex hyperbolic cosine of current stack pointee} 
VAR z: cmplx; 

BEGIN 

z[ 1] := zpt*.r; z[2] := zpt*. i; 
cexp; 

keyin(z); negate; cexp; add; 

zpt*.r:= 0.5#zpt*.r; zpt*.i:= 0.5*zpt*.i; 

END; 


BEGIN {Initialize stack pointer; define it as head; zero pointee} 

NEW(zpt); 
zroot:= zpt; 

zpt*.prev: = NIL; zpt*.next: = NIL; 
clear; 

END. 


LISTING.TXT Contributed by David Gedeon. Accompanies "Programming Insight: Complex Math in Pascal," July 1987, page 121. 


LISTING 1 - available operations 
PROCEDURE negate; 

{Negative of current stack pointee} 

BEGIN 

zpt*.r := -zpt*.r; 
zpt*.i := -zpt*.i; 

END; 

PROCEDURE conjugate; 

{Complex conjugate of current stack pointee} 

BEGIN 

zpt* .i : = - zpt*.i; 

END; 

PROCEDURE invert; 

{Inverse of current stack pointee} 

VAR mag: REAL; 

BEGIN 

mag : = (zpt*.r # zpt*.r) + (zpt*.i* zpt*.i); 
zpt*.r:« zpt*.r/mag; 
zpt*.i := -zpt*.i/mag; 

END; 

PROCEDURE add; 

{Adds current and previous stack pointees; pops stack; result in new pointee} 

VAR a, b: REAL; 

BEGIN 

a : =zpt*.r; b := zpt*.i; 
pop; 

zpt*.r := zpt*.r + a; 
zpt*.i :■ zpt*.i + b; 

END; 

PROCEDURE subtract; 

{Subtracts current from previous stack pointee; pops stack; result in new pointee} 
BEGIN 
negate; 
add; 

END; 

PROCEDURE multiply; 

{Multiplies current and previous stack pointees; pops stack; result in new pointee} 
VAR a, b, c, d: REAL; 

BEGIN 

a :«* zpt*.r; b := zpt*.i; 
pop; 

c :■ (a * zpt* ,r) - (b # zpt*. i); 
d :■ (a # zpt*•1) + (b * zpt*.r); 


continued 
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zpt'.r := c; 
zpt A .i : = d; 

END; 

PROCEDURE divide; 

{Divides previous stack pointee by current; pops stack; result in new pointee} 
BEGIN 
invert; 
multiply; 

END; 

PROCEDURE cexp; 

{Complex exponential function of current stack pointee} 

VAR mag: REAL; 

BEGIN 

mag := EXP(zpt'.r); 
zpt".r := mag#COS(zpt“.i); 
zpt'.i := magKSINCzpt'M); 

END; 

PROCEDURE sinh; 

{Complex hyperbolic sine of current stack pointee} 

VAR z: cmplx; 

BEGIN 

z[l] := zpt\r; z[2] := zpt\i; 
cexp; 

keyin(z); negate; cexp; subtract; 
zpt*.r := 0.5*zpt'\r; zpt\i := 0.5*zpt A .i; 

END; 

PROCEDURE cosh; 

{Complex hyperbolic cosine of current stack pointee} 

VAR z: cmplx; 

BEGIN 

z[l] := zpt A .r; z[2] :=zpt*.i; 
cexp; 

key in (z); negate; cexp; add; 

zpt\r := 0.5*zpt*.r; zpt".i :* 0.5*zpt".i; 

END; 


36 
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QDRGNINT.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QDEKNGCH.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QHILBRT.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QSRPNSK.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QPENTGRE.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QSNOFLK.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123 


6 

TA 

4 

OR 

6 



4 

TA 

0 

60R 

1 

5 

0 


<12 0 1 


38 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 









August 


TA 

120R 




4 

2 

3 

1 

2 

TA 

180R 




4 

3 

4 

2 

3 

TA 

240R 




4 

4 

5 

3 

4 

TA 

300R 




4 

5 

0 

4 

5 

1 

0 




2 

5 

50 


150 


QAROHEAD.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals'’ by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QBRKINT.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123 
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QBRICK.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. 


and Jane Morrill Tazelaar, August 1987, page 123. 
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QLACE.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987. page 123 
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QDRGBDRY.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QMDLQUIN.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QMOORE.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QSRPNSK2.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QCHRSTRE.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QDRGNCRD.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QDRGN.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 
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QGOSPER.CRV Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123 


6 

7 

12 






TA 

OR 







7 

0 

7 

9 

2 

0 

0 

11 

TA 

60R 







7 

1 

8 

10 

3 

1 

1 

6 

TA 

120R 







7 

2 

9 

11 

4 

2 

2 

7 

TA 

180R 







7 

3 

10 

6 

5 

3 

3 

8 

TA 

240R 







7 

4 

11 

7 

0 

4 

4 

9 

TA 

300R 







7 

5 

6 

8 

1 

5 

5 

10 

TA 

OR 







7 

5 

6 

6 

8 

3 

1 

6 

TA 

60R 







7 

0 

7 

7 

9 

4 

2 

7 

TA 

120R 







7 

1 

8 

8 

10 

5 

3 

8 

TA 

180R 







7 

2 

9 

9 

11 

0 

4 

9 

TA 

24 OR 







7 

3 

10 

10 

6 

1 

5 

10 

TA 

300R 







7 

4 

11 

11 

7 

2 

0 

11 

3 

0 

4 

2 





10 

3 

220 

120 





SZPAK.LST The following five listings accompany "Logic Grammars" by Stan Szpakowicz, August 1987, page 185. 


Listing 1: 

statements —> statement, [»;'], statements. 

statements —> [ ]. 

statement —> [skip]. 

statement—> [id(V)], [:«], expr. 

statement—> [if], condition, [then], statements, [fi], 

statement— > [while], condition, [do], statements, [od]. 

condition —> [not], relation, 
condition — > relation, 
relation —> expr, comp_op, expr. 
comp_op —> ['■']. 
comp_op —> [■<•]. 
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expression --> primary. 

expression —> expression, arith_op, primary. 

primary —> [id(V)]. 
primary —> [num(N) ]. 

arith_op — > [' + *]. 
arith_op —> ['-']• 
arith_op —> [•*•]. 
arith_op —> ['/*]. 

[end listing 1] 

Listing 2: 

1*1*1 statement^, N) 

token(id(V), K, L), token(: = , L, M), expr(M, N). 

1*2*1 expr(K, L) :-primary(K, L). 

1*3*1 expr(K, N) :-expr(K, L), aritluop(L, M), primary(M, N). 

/*4*/ primary(K, L) token(id(V), K, L). 

1*5*1 primary(K, L) token(num(V), K, L). 

1*6*1 arith_op(K, L) :-token(+, K, L). 

1*7*1 token(T, [T|Ts], Ts). 

[end listing 2] 

Listing 3- 

program(s(Stmt, Stmts)) —> 

statement(Stmt), [';']# 
statements(Stmts). 

statements(s(Stmt, Stmts)) —> 
statement(Stmt), [';*], 
statements(Stmts). 
statements(skip) —> []. 

% a sequence of statements is represented as a nested term, 

% for example s(Stmtl, s(Stmt2, s(Stmt3, skip))), 

% where Stmtl, Stmt2, Stmt3 represent individual statements 

statement(skip) —> [skip]. 
statement(let(V, E)) —> [id(V)], [:=], expr(E). 
statement(if(C, Stmts)) —> 

[if], condition(C), [then], statements(Stmts), [fi]. 
statement(while(C, Stmts)) —> 

[while], condition(C), [do], statements(Stmts), [od]. 

condition(not(C)) —> [not], relation(C). 
condition(C) —> relation(C). 

relation(cond(Op, El, E2)) —>expr(El), comp_op(Op), expr(E2). 

comp_op(' =') —> [’*']. 
comp_op('<') —> [*<']. 

[end listing 3] 

Listing 4: 

interm_code(s(Stmt, Stmts)) —> 

interm_code(Stmt), interm_code(Stmts). 
interm_code(skip) —> []. 
interm_code(let(V, E)) --> 

expr_internucode(E), [store(V)]. 
interm_code(if(C, Stmts)) —> 

{ newlabel(L) }, 
cond_interm_code(not(C)), 

[Jmp_cond(L)], 
interm_code(Stmts), 

[label(L)]. 

interm_code(while(C, Stmts)) —> 

{ newlabel(Ll) ), { newlabel(L2) }, 

[label(Ll)], 

condLinterm_code(not(C)), 

[Jmp_cond(L2)], 
interm_code(Stmts), 

[Jmp(Ll)], [label(L2)]. 

[end listing4] 


continued 
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Listing 5: 

The source program: 
x := a; y : = n; z := 1; 
while not i < 1 do 
if y/ 2#2< y then 
z := z # x; 
fi; 

x := x # x; 
y : = y/2; 
od; H 

The resulting object code: 

load(a) 

store(x) 

load(n) 

store(y) 

loadc(l)store(z) 

label($lbll) 

loadc(l) 

store($meml) 

load(i) 

sub($meml) 

tst_neg 

jmp_cond($lbl2) 

etc. 

[end listing 5] 


SZPAK.BNL Contributed by Stan Szpakowicz. 

Accompanies “Logic Grammars" by Stan Szpakowicz, August 1987, page 185. Written in Prolog using logic grammars. 


% 

* Note: In order to execute this program, a Prolog interpreter must support logic grammars or definite-clause grammars 

% = = - main program === 
compile 

set_gensym( "$lbl" ), set_gensym( "$mem" ), 
read_in( Chars ), 
lsym_list( LexSyms, Chars, [] ), 
program( Tree, LexSyms, [] ), 
interm_code( Tree, Code, [] ), 
write_out( Code ), !. 
compile :-write( ’Sorry' ), nl. 

% read in a sequence of characters terminated by a tf 
read_in( Chars ) get( Ch ), read_in( Ch, Chars ). 

read_in(35, []):-!. %H 

read_in( Ch, [Ch | Chars] ) :-getO( Chi), read_ln( Chi, Chars ). 

% print the generated code one instruction per line 
write_out( [ ] ). 
write_out( [Instr| Instrs] ) 

write( Instr ), nl, write_out( Instrs ). 


% (skips initial white space) 
% lexical analysis 
% syntactic analysis 
% code generation 


% **= scanner =«■* 

% list of lexical symbols 
lsym_list( [LexSym | LexSyms] ) —> 

lsym( LexSym ), !, opt_space, lsym_list( LexSyms ). 
lsym_list( [])—>[]. 

% one lexical symbol (input tokens are ASCII codes) 
lsym( IdOrKwd ) —> letter( L ), alphanums( Ls ), 

{ name( Nm, [L | Ls] ) }, { wrap_name( Nm, IdOrKwd ) }. 
lsym( num( N ) ) —> digit( D ), digits( Ds ), 

{ name( N, [D | Ds] ) }. 

lsym( : = ) —> [58], [61]. % colon, equals 

lsym( S ) —> [Ch], { name( S, [Ch] ) }. 
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% optional white space between lexical symbols 
opt_space—>white_space, !, opt_space. 
opt_space —> [ ]. 

% recognizing classes of ASCII codes 
letter( L ) — > [L], { is_letter( L ) }. 
digit( D ) —> [D], { is_digit( D ) }. 
white_space—> [Ch], { is_white_space( Ch ) }. 

is_letter( Ch ) 65 =< Ch, Ch =< 90. 
is_letter( Ch ) 97 =< Ch, Ch =< 122. 

is_digit( Ch ) 48 =< Ch, Ch =< 57. 

is_white_space( 32 ). X blank space 

is_white_space( 13 ). % new line (this would be 10 in Quintus Prolog) 

is_white_space(9). X tab 

t 

% keywords and identifiers 

alphanums( [L | Ls] ) —> letter( L ), alphanums( Ls ). 
alphanums( [L | Ls] ) —> digit( L ), alphanums( Ls ). 
alphanums( [ ] ) —> []. 

wrap_name( Nm, Nm ) is_keyword( Nm ). 
wrap_name( Nm, id( Nm ) ). 

% table of keywords 

is_keyword( if ). is_keyword( then ). is_keyword( fi ). 

isJceyword( while ). is_keyword( do ). is_keyword( od ). 

is_keyword( skip ). is_keyword( not). 

X integers 

digits( [D I Ds] ) —> digit( D ), digits( Ds ). 
digits( [])-->[]. 

% === parser 

program( s( Stmt, Stmts) ) —> 

statement( Stmt ), [';'], 
statements( Stmts ). 

statements( s( Stmt, Stmts) ) —> 

statement Stmt), [•;'], !, 
statements ( Stmts ). 
statements( skip ) --> [ ]. 

X a sequence of statements is represented as a nested term, 

X for example s( Stmtl, s( Stmt2, s( Stmt3# skip ) ) ), 

X where Stmtl, Stmt2, Stmt3 represent individual statements 

statement skip ) —> [skip]. 

statement^ let( V, E ) ) —> [id( V )], [:«], expr( E ). 
statement^ if( C, Stmts ) ) — > 

[if], condition( C ), [then], statements( Stmts ), [fi]. 
statement while( C, Stmts ) ) —> 

[while], condition( C ), [do], statements( Stmts ), [od], 

condition( not( C ) ) —> [not], relation( C ). 
condition( C ) —> relation( C ). 

re la t ion ( cond( Op, El, E2 ) ) —> expr( El), comp_op( Op ), expr( E2 ). 

comp_op( •■' ) —> [*■*]. 
comp_op( '<* ) —> ['<’]. 

expr( E ) —> add_expr( AE ), rest_expr( AE, E ). 
rest_expr( AE1, E ) —> 

['+'], add_expr( AE2 ), rest_expr( e( ' + AE1, AE2 ), E ). 
rest_expr( AE1, E ) —> 

[*-'], add_expr( AE2 ), rest_expr( e( AE1, AE2 ), E ). 
rest_expr( E, E ) —> [ ]. 

add_expr( AE ) —> mult_expr( ME ), rest_add_expr( ME, AE ). 
rest_add_expr( ME1, AE ) —> 

['»'], mult_expr( ME2 ), rest_add_expr( e( ' *', ME1, ME2 ), AE ). 


continued 
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rest_add_expr( ME1, AE ) —> 

['/']> mult_expr( ME2 ), rest_add_expr( e( • /', ME1, ME2 ), AE ). 
rest_add_expr( E, E ) —> [ ]. 

mult_expr( var( V ) ) — > [id( V )]. 
mult_expr( num( N ) ) —> [num( N )]. 
mult_expr( E ) —> [•('], expr( E ), [')']. 

% === code generation === 

% statements 

interm_code( s( Stmt, Stmts ) ) —> 

interm_code( Stmt), interm_code( Stmts ). 
interm_code( skip ) —> [ ]. 
interm_code( let( V, E ) ) —> 

expr_interm_code(E), [store( V)]. 
interm_code( if( C, Stmts ) ) —> 

{ newlabel(L ) }, 
cond_interm_code( not( C ) ), 

[Jmp_cond( L)], 
interm_code( Stmts ), 

[label( L)]. 

interm_code( while( C, Stmts ) ) —> 

{ newlabel( LI) }, { newlabel( L2 ) }, 

[label( LI )], 

cond_interm_code( not( C ) ), 

[jmp_cond( L2 )], 
interm_code( Stmts ), 

[Jmp(Ll)], [label( L2 )]. 

X conditions 

cond_interm_code( not( not( C ) ) ) —> cond_internucode( C ). 
cond_interm_code( not( R ) ) —> 

rel_interm_code(R), [flip]. 

X flip: negate the contents of the condition register 
cond_interm_code( R ) ~> 

rel_interm_code( R). 

X relations 

rel_interm_code( cond( Op, El, E2 ) ) —> 

expr_interm_code( E2 ), { newmemloc( M) }, [store( M)], 
expr_interm_code( El), [sub( M )], tst_interm_code( Op ). 

% set the condition register 
tst_interm_code( ' =' ) —> [tst_zer]. 
tst_interm_code( '<* ) —> [tst_neg]. 

X expressions 

expr_interm_code( e( Op, El, E2 ) ) —> 

expr_lnterm_code( E2 ), { newmemloc( M) }, [store(M)], 
expr_internucode( El), eop_interm_code( Op, M ). 
cxpr_interm_code( var( V ) ) —> 

[load( V)]. 

X load a constant 
expr_interm_code( num( N ) ) —> 

[loadc(N)]. 

eop_interm_code( ' +», M) — > [add( M)]. 
eop_internucode( , M ) —> [sub( M )]. 
eop_interm_code( »*», H) — > [mul( M)]• 
eop_interm_code( */•, M) —> [div( M)]. 

% auxiliaries 
newlabel( L) :- 

gensym( "$lbl M , L ). 
newmemloc(M) :- 

gensym( M $mem", M ). 

% === utilities = = = 

% symbol generator (preset in the main program) 
set_gensym( Pref ) 

retract( sym( Pref, _) ), fail. 
set_gensym( Pref ) 

assert( sym( Pref, 1 ) ). 

gensym( Pref, Sym ) 

retract( sym( Pref, Num ) ), 
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Numl is Num + 1, 

assert( sym( Pref, Numl ) ), 

glue( Pref, Num, Sym ). 

glue( Pref, Num, Sym ) 

name( Num, Digits ), append( Pref, Digits, All ), 
name( Sym, All), !. 

% well, you can' t have a program without append... 
append( [], Z, Z). 

append( [A | X], Y, [A | Z] ) :-append( X, Y, Z ). 

X end of program 


DRAGON.BAS Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 


1 '_DRAGON PROGRAM_ 

2 ' 

3 'This is the DRAGON.BAS program in Microsoft BASIC for the IBM PC and compatibles. If you have QuickBASIC, QDRAGON.BAS is 

4 'easier to use and comes with quite a few dragon files (.CRV) that will make your fractal wanderings considerably easier. 

5 ' If you do not have that package, this program is fun and allows you to explore the dragons. It is not, however, 

6 ' forgiving of mistakes. Any data-entry mistakes require that you start over. Have a good time! 

7 • 

8 ' 

9 1 2 3 4 5 6 7 8 9 
11 ' 

12 'To avoid local variables, I have replaced the loop index K with a one-dimensional array K, which holds the loop index 

13 'at each level of recursion, and exchanged the variable CELL for a one-dimensional array CELL, which holds the cell 

14 'value at each level of recursion. Since Microsoft BASIC does not permit subscripted variables to be FOR.. .NEXT loop 

15 ' indexes, I have replaced this loop with a WHILE.. .WEND block. 

16 • 

17 ' 

18 ' 

20 •-Initialize 

30 DATA 14,12,11,13,10,9,15 
40 CLEAR,,10000 

42 CLS 

. RM63/46 FOR 1=1 TO 7 

48 READ X 

49 NEXT I 

50 '-Get dragon 

60 INPUT; "DRAGON FROM DISK (<CR> if no) ",C$: IF C$>"" THEN G0SUB 360:PRINT:GOTO 210 

70 INPUT"NUMBER OF DIRECTIONS" ;D: INPUT"NUMBER OF CELLS (equal or greater the number of directions) ";M: IF M<D THEN 70 
80 INPUT"MAX NUMBER OF CELLS IN A CELL DIVISION"; L:PRINT"Follow each input cell with <CR>" :DIM G(M-1,L) 

90PRINT"cyclic? (<CR> if no)»:IF INPUT$(l)=CHR$(13) THEN 140 

100 J=0:WHILE J<M:PRINT"division of cell"J"(enter '.' after last cell of division less than"L:G(J,0)=L 
110 FOR 1=1 TO L:INPUT;" ",A$:G(J,I)«VAL(A$):IF INSTR(A$,".") THEN G(J,0) = I: I=L 

120 NEXT I :PRINT:FOR 1*1 TO G(J,0) :S=G(J,1) :T=S-(S MOD D):FOR K=J+1 TO J+D-1:G(K,0)=G(J,0) :G(K,I)=((S+K) MOD D)+T:NEXT K, I 
130 J-J+D: WEND: GOTO 170 

140 FOR J=0 TO M-1:PRINT"DIVISION OF CELL"J"(enter (.) after last cell of divisions less than"L:G(J,0)=L 
150 FOR 1=1 TO L:INPUT;" ",A$:G(J,I)=VAL(A$) :IF INSTR(A$,".") THEN G(J,0) = I:I=L 
160 NEXT I: PRINT:NEXT J 

170 DIM I(M-l) :PRINT"If cell directions are CELL modulo NUMBER OF DIRECTIONS, then press <CR>": IF INPUT$(l) =CHR$(13) THEN FOR 1=0 
TO M-l: I (I) = I MOD D: NEXT I: GOTO 210 

180 FOR I=0 TO M-l:PRINT"DIRECTION FOR CELL"I;:INPUT I$:IF 1$="." THEN I(I)=-1 ELSE I(I)=VAL(I$) 

190 NEXT I 

200 f -Compute direction vectors 

210 T=6.28318531^/D:DIM X(D-l),XX(D-1),Y(D-l),YY(D-l): FOR 1=0 TO D-1:XX(I)=C0S(I#T): YY(I)*SIN( I#T) :NEXT I 
220 '-Get drawing parameters 

230 INPUT"NUMBER OF BIRTH CELLS IN START PATTERN ";T:PRINT»Follow each birth cell input with <CR>" :DIM W(T-l): FOR 1=0 TO 
T-l: INPUT;" ", W(I) :NEXT I:PRINT 

240 INPUT; "AGE IN DAYS ", DAY: INPUT;" CELL LENGTH »,W:F0R 1=0 TO D-1:X(I)=W#XX(I) :Y(I)=W*YY(I): NEXT I: PRINT 
250 INPUT;" COORDINATES OF HEAD CELL (", X: INPUT;",", Y: PRINT")": DIM K(DAY),CELL(DAY) 

260 *-Draw dragon and repeat 

270 CLS 

271 SCREEN 2 
273 PRESET(X,Y) 

275 FOR 1=0 TO T-l 
277 CELL(DAY)=W(I) 


continued 
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278 GOSUB 310 

279 NEXT I 

280 PRINT"(1)NEW BIRTH CELL LIST, (2)NEW AGE, (3)SAVE TO DISK ": A$=INPUT$(l) :0N INSTR(»123", A$) GOTO 330,340,400 
290 RUN 

300 '-Dragon procedure 

310 IF DAY=0 THEN CODE=I(CELL(DAY)) :G0SUB 450:RETURN 

320 K(DAY)=1:WHILE K(DAY)<=G(CELL(DAY) ,0) :CELL(DAY-l)=G(CELL(DAY),K(DAY)) :DAY=DAY-1:GOSUB 

310:DAY=DAY+1:K(DAY)=K(DAY)+1:WEND:RETURN 

330 ERASE W, K, CELL: GOTO 230 

340 ERASE K,CELL:GOTO 240 

350 '-Load dragon routine 

360OPEN"I",l,C$+".CRV":INPUT# 1,D,M,L:DIMG(M-1,L) ,I(M-1) 

370 FOR 1=0 TOM-1: INPUT# 1,G(I,0) :FOR J=1 TO G(l,0): INPUT# 1,G(I, J) :NEXT J, I 
380 FOR 1=0 TO M-l: INPUTS 1,1(1): NEXT I: CLOSE: RETURN 

390 '-Save dragon routine 

400 INPUT"CURVE NAME";C$:OPEN "0",1,C$+".CRV" 

410 PRINT# l,D;M;L:FOR 1=0 TO M-l:PRINT# 1,G(1,0); :F0R J=1 TO G(I,0) 

420 PRINT# 1,G(I, J); :NEXT J:NEXT I:FOR 1=0 TO M-l:PRINT# 1,1(1);:NEXT I 
430 CLOSE:GOTO 280 

440 '-Routine to interpret a cell 

450 IF C0DE<0 THEN RETURN 

460 IF C0DE<DTHEN X=X+X(C0DE):Y=Y-Y(C0DE):LINE-(X,Y),I MOD 7+l:RETURN 
470 X=X+X(C0DE-D):Y=Y-Y(CODE-D):PRESET(X,Y):RETURN 


QRULES.TXT Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 


Running QDRAGON 

The new QDRAGON.BAS is written in QuickBASIC to exploit the DRAW commands and to make data entry less tedious. As I understand it, 
only the SCREEN commands must be changed to suit the graphics adapter available. The LINE commands have been replaced by DRAW 
commands to permit drawing cells that are more exotic than simple line segments. The default is a line segment drawn in a direction 
determined by the cell label number. The length of the line segment is determined by scale factor held in the "cell length" variable. 
If something else is desired, you must type in the appropriate sequence of DRAW commands. Such a sequence will be sized by the value 
in the "cell length" variable. The program displays the DRAW commands it will use. 

QDRAGON.BAS improves on the user interface but is not yet ideal. It pretends it knows what you want as data and displays what it will 
use if you don' t enter any data. Pressing Return repeatedly will show currently recorded data and how the program wants the data typed 
in. Pressing FI at any time will draw the dragon determined by current data. The program always has complete data to draw some 
dragon. To enter data for a new dragon, simply enter the data requested followed by Return. To back up and change or view previously 
requested data, end entry with a ]. 

The first thing the program wants to know is if you want a dragon stored on disk. Pressing Return or ] ignores this request and 
displays the next, or previous, thing it wants. Otherwise you type in the name of a dragon stored on disk followed by Return or ], or FI 
if you want the program to draw the dragon you have named. Dragons stored on disk contain #all# the data required by the program, 
including positioning on the screen and the birth cell list. Hence loading a dragon from disk can be followed immediately by FI which 
will draw it on the screen. 

The next thing the program wants is the number of directions. This request is the number of cell orientations. Entering the number 4 
means all cells are oriented in four directions, east, north, west, or south, as if reading a map. The program assumes that all cells 
are single line segments oriented in one of four directions unless told otherwise by you or the input file. In any case, the program 
will display the DRAW commands it will use. Entering the DRAW commands wanted (followed by Return, ], or FI) changes the default 
value. Pressing ] following data entry displays what the program thinks you typed. 

Following the 'number of directions' request, QDRAGON.BAS wants the maximum cell division. This is so that the program can begin to 
dimension the genetic code array. You type in this value if it differs from the displayed value (Return cycles forward through data 
entry). The genetic code requires two dimensions, so if FI is pressed now, all entries in the genetic code array will be zero, 
producing a dull dragon. The program redimensions the genetic code array whenever one of its dimensions is changed. 

Next, the program wants the total number of cell types. This number completes the dimension of the genetic code array. The program 
displays, as always, what it thinks should be the number of cell types. Typing Return accepts the program's choice and displays what 
the program wants next and the value it will use if you don't change it. 

After typing Return, the program displays the DRAW commands it will execute for the first cell. You should type Return to go on to 
the next program request, or type in the DRAW commands you want for the first cell followed by Return to advance to the next request or 
] to edit or preview the previous request. If you want a cell to be an invisible line segment, typing a dash will cause the program to 
record the appropriate DRAW commands, and if you want a 'do nothing' cell, typing * makes the program fill in DRAW commands that do the 
Job. 
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Ending the entry with Return, the program will now exhibit the label of the first child of the first cell. Each cell divides into a 
number of cells, numbered from one to the number of cells into which the cell divides. A user entry here should be a cell label, a 
number between 0 and one less than the total number of cells. Typing Return causes the program to ask for the next child of the 
current cell. If the cell has fewer children than the maximum, the last child cell should be followed by a period. 

Whenever the program asks you for the last child of a cell labelled a multiple of the number of directions, it permits you to end 
entry vfith an # to abort this feature. Without the # entry, the program will fill in child cells cyclically up to the next cell 
labelled a multiple of the number of directions and display the draw code for the next cell, which is a multiple of the number of 
directions. 

After all cells and their children have been displayed, the program requests the number of cells in the birth cell list. Dragons can 
begin life as a single cell (number of cells in birth cell list, 1) or as several cells, each drawn in a different color. Next the 
dragon’s age in days is requested. Following this comes a request for cell length and the position on the screen where drawing is to 
begin. The program draws the dragon starting at this position. 

Finally, the program asks if the dragon just drawn is to be saved on disk. If so, you type a name of up to 8 letters followed by Return 
or ]. Only Control-Break or illegal data entry ends the program. 

QDRAGON.BAS displays DRAW commands instead of numbers, so ignore interpreter values in the table. The relation between interpreter 
values in the table and the draw codes in the program is I->TA360I/DR. Invisible cells end in BR and 'do nothing' cells end in NBR. 

Have a good time exploring fractals. I have. 

-William A. McWorter Jr. 


QDRAGON.BAS Contributed by William A. McWorter Jr. 

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123. 


' This program is QDRAGON.BAS, a QuickBASIC program for drawing fractals. 

' Inputs to this program are the files with a .CRV suffix. Rules for running it are in QRULES.TXT. 


d=4:l=2:m=4:w=l:s=10:n=5:x=320:y=175 

dim i$(m-l),g(m,l),w(w):a=360/d 

prinf'The program tries to anticipate your wishes." 

prinf'You can cycle through the data for previewing" 

prinf'or editing, or enter entirely new data." 

print"<cr> cycles forward through data entry" 

print"<]> cycles backwards through data entry." 

print"<Fl> at any time draws the dragon with current data." 

prinf'But pressing it now will get you only an empty screen." 

prinf'The backspace key allows erasing the last-typed character." 

print 

begin: print" input dragon? (<cr> or<]> if no) :t=pos(0)+l:gosub getcmd 

ifi$>" "then 
open"I",01,1$+".crv" 

input01,d,l,m:redim i$(m-l) ,g(m,l) :a=360/d 

for i*0 to m-1: input^l, i$(i) :for J=0 to 1: input01,g(i,J) :next J,i 

lnput#l,w:redim w(w) :for i=l to w: inputs,w(i) :next i 

input#l,s,n,x,y:close 

end if 

11’ a$*"]" then gotocrvsave 
If a$=chr$(0) then goto program 
locate csrlin,pos(0) ,1 

drctns: print''number of directions"; 
t=pos(0)+l: print d; :gosub getcmd 
If i$>" " then d=val( i$) :a=360/d 
If a$=chr$(0) then goto program 
1 f a$=" ]" then goto begin 

dvsn: prinf'max cell division"; 

t=pos(0)+l: print 1; :gosub getcmd 

if i$>" " then l=val(i$):redim g(m-l,l), i$(m-l) 

If a$=chr$(0) then goto program 
If a$="]" then goto drctns 


continued 
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cellno: print"number of cells"; 

t=pos(0)+l:print m; :gosub getcmd 

if i$>" " then m=val(i$):redim g(ra-l,l), i$(m-l) 

if a$=chr$(0) then goto program 

if a$="]" then goto dvsn 

i=0:J =1 


gnetic.-if i$(i)=" " then i$(i)="TA"+str$((i mod d)*a)+"R" 

if g(i,0)=0 then g(i,0)=l 

drawcode: prinf'draw code for cell"i"is"; 

t=pos(0)+l:print" "i$(i)"<*> = 'donothing'; <-> = 'invisible' 
gosub getcmd 
if i$>" "then 

if instr( i$, "#") then i$(i)="TA"+str$((i mod d)#a)+"NBR":goto drawcodel 
if instr(i$,then i$(i)="TA"+str$( (i mod d)*a)+"BR":goto drawcodel 
i$(i)=i$ 
end if 

drawcodel: if a$=chr$(0) then goto program 
if a$="]" then 

i«i-l:if i<0 then goto cellno else j=g(i,0) :goto loop 
end if 


J-l 

loop: print" cell"i'"s number"J "child is"; 
t=pos(0)+l:print g(i,j); 
if J=g(i,0) then 

if (i mod d)=0 then print" (end this entry with (#) to abort skip)"; 
end if 

gosub getcmd 
if i$>" "then 

g(i,J)-val(i$): if instr(i$,".") then g(i,0)«J 
end if 

if a$=chr$(0) then goto program 

if a$="]" then 

if J =1 then goto gnetic 

J=J-l:goto loop 

end if 

J=J+1: if j<=g(i,0) then goto loop 
if (i mod d)<>0 then i*i+l:goto ilupend 
if i+d<=ra then 

if i$=" " then i=i+l:goto ilupend 
if instr(i$,"»") then i=i+l:goto ilupend 
for u=i+l to i+d-1 
if i$(i) =" " then i$(u) = " ":goto 10 

if instr( i$( i), "B") then i$(u) ="TA"+str$( (u mod d)«a)+"BR":goto 10 
i$(u)="TA"+str$((u mod d)#a)+"R" 

10 g(u,0)=g(i,0) :for v=l tog(i,0) 
g(u,v)=g(i,v)-(g(i,v) mod d)+((g(i,v)+u) mod d) 
next v,u: i*i+d:goto ilupend 
end if 
i=i+l 

ilupend: if i<m then J =1: goto gnetic 

initword:print"birth cell list length"; 

t=pos(0)+l:print w; :gosub getcmd 

if i$>" " then w=val(i$):redim w(w) :goto bcells 

if a$=chr$(0) then goto program 

if a$="]" then i=m-l: J=g(i,0) :goto loop 

bcells: i«l:print"cells" 
loopl: print i"-th cell:"; 
t=pos(0)+l:print w(i); :gosub getcmd 
ifl$>" " then w(i)=val(i$) 
if a$=chr$(0) then goto program 

if a$="]" then if i=l then goto initword else i=i-l:goto loopl 
i=i*H:if i<«w then goto loopl 

order:print"number of day's growth"; :t=pos(0)+l:print n;:gosub getcmd 
if i$>" " then n*val(i$) 
if a$=chr$(0) then goto program 
if a$="]" then i»w: goto bcells 
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length: print" cell length"; 
t=pos( 0 )+l:print s; :gosub getcmd 
if i$>" " then s=val( i$) 
lfa$=chr$( 0 ) then goto program 
if a$="]" then goto order 

xpos:print"x-origin"; 
t=pos( 0 )+l: print x; :gosub getcmd 

ifi$>" " thenx=val(i$) 
if a$=chr$( 0 ) then goto program 
if a$="]" then goto length 

ypos:print"y-origin"; 
t=pos( 0 )+l:print y; :gosub getcmd 
ifi$>" " theny=val(i$) 
if a$="]" then goto xpos 
if a$=chr$( 0 ) then goto program 

crvsave: print"save name? (<cr> or<]> if no) ";: t=pos( 0 )+l:gosub getcmd 

if i$="]" then goto ypos 

ifi$>" "then 

open" 0 ", 1 ,i$+".crv" 

print#l,d;l;m 

for i=0 to m-l:print#l,i$(i) :for J=0 to l:print#l,g(i,j); 
next J:print#l,:next i 

print#l,w; :for i=l to w:print#l,v(i); :next i:print#l, 
print#l,s;n;x;y:close 
end if 

if a$="]" then goto ypos 
if a$=chr$( 0 ) then goto program 
goto begin 

program:screen 2 :els:dim k(n),cell(n) 
draw"BM="+varptr$(x)+",="+varptr$(y) 

for i=2 to w+l:cell(n)=w(i-l) :draw"C="+varptr$(i) :gosub dragon:next i 
erase k,cell:goto crvsave 

dragon: 

if n =0 then draw i$(cell(n))-»-str$(s):return 

k(n)=l:vhile k(n)<=g(cell(n) , 0 ) :cell(n-l)=g(cell(n) ,k(n)) :n=n-l 

gosub dragon:n=n+l:k(n)=k(n)+l:wend 

return 

getcmd:i$=" ":t 0 =pos( 0 )-l:locate csrlin,t,l 
getcmdl: a$=" ":a$=input$(l) 

if instr(chr$( 13 )+"]"+chr$( 0 ),a$) then print:return 
if a$=chr$( 8 ) then 
1 f pos ( 0 ) = t then goto getcmdl 

i$=left$(i$,len(i$)-l): locate csrlin,pos( 0 )- 1 , 1 :goto getcmdl 
end if 

I$=I$+a$:print a$; 

if len(i$)=l then print string$( t 0 -t+ 2 , 32 );: locate csrlin, t+ 1,1 
goto getcmdl 


INDEX.PAS Contributed by Dick Pountain. Accompanies "Focus on Algorithms: Search and Destroy," August 1987, page 257. 


{ INDEX.PAS in Turbo Pascal 3.0 for IBM PC and compatibles } 

{ A book indexing program — requires an input file — execute as .COM ) 

{ Also requires a Boring Words dictionary, BORING.DIC, in the .COM file's directory } 

{ To execute .COM file, enter "index <inputfilename><outputfilename> } 
program INDEX; 

const CR = #13; { carriage return character ) 

const maxDict = 3750; {maximum allowable dictionary entries} 

type letters = ' a 1 .. 1 z •; 
word type* string[l6]; 
nodeptr * "nodetype; 
node type* record 

info: word type; 


continued 
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next: nodeptr 
end; 

var inputFile,outputFile: text; 

inputFilename, outputFilename: string[127]; 

chr,flrstletter: char; 

sortList: array [letters] of nodeptr; 

i: letters; 

word: wordtype; 

boringWords: array [1. .maxDict] of wordtype; 
dictionary : text; 
endDict : integer; 
procedure InitFiles; 

begin { open input and output files } 

inputFilename := paramSTR(l); 

Assign(inputFile,inputFilename); 

Reset(inputFile); 
outputFilename :* paramSTR(2); 

Assign(outputFile, outputFilename); 

Rewrite(outputFile); 
end; 

procedure GetWord(VAR infile: text; VAR word: wordtype); 
begin { read a cleaned-up word from the input file } 

word : = ' *; 
repeat 

read(infile,chr); 

if chr in [ 1 A f • • * Z' ] 

then chr : = char(ord(chr)+32); 

if chr in ['a'..'z'] 

then word : = word+chr; 

until (chr = * ') or (chr = CR) or eof (inf ile) 
end; 

procedure Place (VAR list: nodeptr; word: wordtype); 
var p,q,newnode: nodeptr; 


{ the array of 26 lists } 


{ initialize to blank } 


{ convert all to lowercase } 

{ only accept alpha characters } 
{ add to word being built} 


found: boolean; 
begin 
q := nil; 
p := list; 
found :* false; 
while (p<> nil) 
and (not found) 
and (word >= p". info) do 
if p*. info = word 
then found : * true 
else begin 
q := p; 
p : = p*.next 
end; {while} 
if not found 
then begin 
New(newnode); 
newnode*.info :» word; 
if q = nll 
then begin 

newnode*.next :■ list; 
list :* newnode 
end 

else begin 

newnode*.next :=q*.next; 
q*.next : = newnode 
end 
end 
end; 


{ insert new word into list in sorted position only if unique } 

{ p points to head of list } 

{ not end of list and } 
{ word not already here and } 
{ word alphabetically later than current} 
£ does this node contain our word? } 
{ yes! word is already here } 

{ remember this node and } 
{ move on to the next one } 

{ word isn * t already here } 

{ create a new node } 
{ put word in its info field } 
{ list was empty } 

{ newnode becomes first} 


{ insert after node q } 


procedureSquirtOut(list: nodeptr; VARoutfile: text); 
begin { send sorted list to output file } 

while list <> nil 
begin 

writeln(outfile,list*.info); 
list :«list*.next 
end 
end; 

procedure ReadDictionary; 

var i: Integer; 

begin 

Assign(dictionary,'BORING.DIC 1 ); 

Reset(dictionary); 
i :■ 1; 


repeat 
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readln(dictionary,boringWords[i]); 
i := i + 1 

until eof(dictionary) or (i > maxDict); 

endDict : * i; {number of actual dictionary entries} 

Close(dictionary) 
end; 

function Boring(word: wordtype): boolean; 
var left,right,try,svleft,svright: integer; 
begin 
left s-1; 
right :* endDict; 
repeat 

svleft := left; svright := right; 
try := (left + right) div 2 ; 
if word < boringWords[try] 
then right : = try - 1 
else left :=try + l; 

until (word = boringWords[try]) or (svleft > svright) ; 
if word = boringWords[try] 
then Boring : = true 
else Boring := false 
end; 

begin { main program } 

InitFiles; 

ReadDictionary; 

fori := 'a' to 'z' do sortList[i] :=nil; { initialize all the lists } 

while not eof (inputFile) do 

begin 

GetWord(inputFile,word); 

firstletter : * word[l]; { get first letter } 

if not Boring(word) 

then Place(sortList[f irstletter] ,word); { put word in proper place } 

end; {while} 

fori :» ’a' to *z' doSquirtOut(sortList[i],outputFile); 
writeln('Keywords are contained in ',outputFilename); 

Close(inputFile); 

Close(outputFile) 
end. 


OPS8085.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


% Subject: 0PS8085.ARI - from Alex Lane: "Simulating a Microprocessor" 


comp_regs(Regname) 

retract(state(R,PC,SP,_)), 
reg(Regname,Place), 
arg(Place,R,Reg), 

X is A - Reg, 

adJust_flags(A,X,_,Flags), 
asserta(state(R,PC,SP,Flags)). 


acc_jnath_with_carry(Op,Regname) 

retract(state(R,PC,SP,flags(_,_,_,CY,_))), % get what we need 


% extract A from R 
% Place is location of Regname in R 
% extract register value 
% set up additions/subtractions 


arg(l,R,A), 
reg(Regname,Place), 
arg(Place,R,Reg), 

T1. [Op,Reg,CY], 

T2 ■.. [Op,A,Tl], 

X is T2, % evaluate 

adJust_flags(A,X,Y,Flags), % adjust for flags 

argrep(R,l,Y,NewR), % replace register value in R 
asserta(state(NewR,PC,SP,Flags)). 


acc math(Op,Regname) 

retract(state(R,PC,SP,_)), 
arg(l,R,A), 

reg(Regname,Place), arg(Place,R,Reg), 
Tl-.. [Op,A,Reg], 

X is Tl, 
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adjust_flags(A,X,Y,Flags), 
argrep(R,l,Y,NewR), 
asserta(state(NewR,PC,SP,Flags)). 

reg_math(Op,Regname) 

retract(state(R,PC,SP,flags(_,_,_,CY,_))), arg(l,R,A), 
reg(Regname,Place), % Place is location of Regname in R 

arg(Place,R,Reg), % extract register value 

T1 = .. [Op,Reg,TemReg],* take advantage of Arity inc() and dec() 
call(Tl), 

adj ust_flags(A,TemReg,NewReg,flagsl(Z,S,P,_,AC)), 
argrep(R,l,NewReg,NewR), % replace register value in R 

asserta(state(NewR,PC,SP,flags(Z,S,P,CY,AC))). 

not_implemented. % some things are not worth doing. 

undefined. 

move (mem, mem). 

move(mem,D) 

retract(state(R,PS,SP,F)), 
arg(6,R,H), 
arg(7,R,L), 
get_mem(H,L,Data), 
argrep(R,D,Data,NewR), 
asserta(state(NewR,PC,SP,F)). 

move(S,mem) 

state(R,PS,SP,F), 
arg(6,R,H), 
arg(7,R,L), 
arg(S,R,Data), 
put_mem(H,L,Data). 

move( S,D) 

retract(state(R,P,SP,F)), 
arg(S,R,Sl), 
argrep(R,D,Sl,NewR), 
asserta(state(NewR,P,SP,F)). 

reg_ptr(6,mem). 

reg_ptr(A>B) B is (A + 2) mod 8. 
op(0). /*NOP*/ 

op(l) /* LXI BC */ 

retract(state(regs(A,_,_,D,E,H,L),PC,SP,Flags)), 

get_mem(PC,C), Hi is PC + 1, 
get_jnem(Hi,B), 

NewPC is PC-f 2, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(2) /*STAXB*/ 

state(regs(A,B,C, 
put_mem(B,C,A). 

op(3) /* INX B */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

BC is 256* B + C + l, 
decompose(BC,NewB,NewC), 

asserta(state(regs(A,NewB,NewC,D,E,H,L),PC,SP,Flags)). 

op(4) reg_math(inc,b),!. /#INRB*/ 

op(5) reg_math(dec,b),!. /* DCR B */ 

op(6) /* MVIB, data*/ 

retract(state(regs(A,_,C,D,E,H,L),PC,SP,Flags)), 
get_mem(PC,B), 

NewPC is PC + 1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 
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op(7) 

op(9) 


op(10) : 

op(ll) : 

op(12) : 

op(13) : 

op(l4) : 

op(15) : 


op(17) 

op(18) 

op(19) 

op(20) 

op(21) 

op(22) 


/ * RLC * / 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), 

CY is A mod 128, 

A1 is (2 # A + CY) mod 256, 

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))). 

/# DAD B (CY only)#/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), 

NewL is L + C, 

Carry is NewL/ / 256, 

NewH is H + B + Carry, 

CY is NewH// 256, 

FL is NewL/\ 255, 

FH is NewH / \ 255, 

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))). 

/ # LDAX B # / 

retract(state(regs(_,B,C,D,E,H,L),PC,SP,Flags)), 
get_mem(B,C,A), 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)). 

/# DCX B #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

BC is 256 # B + C - 1, 
decompose(BC,B1,Cl), 

asserta(state(regs(A,Bl,Cl,D,E,H,L),PC,SP,Flags)). 

reg_math(inc,c),!. /#INRC#/ 

reg_math(dec,c),!. /#DCRC#/ 

/#MVIC, data#/ 

retract(state(regs(A,B,_,D,E,H,L),PC,SP,Flags)), 
get_mem(PC,C), 

NewPC is PC + 1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

/ # RRC # / 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), 

CY is A mod 2, 

II is CY# 128, 

Al is A//2+ 11, 

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))). 
/# LXI DE #/ 

retract(state(regs(A,B,C,_,_,H,L),PC,SP,Flags)), 
memory(PC,E), 

Hi is PC + 1, 
memory(Hi,D), 

NewPC is PC+ 2, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

I # STAX D #/ 

state(regs(A,_,_,D,E,_,_),_,_,_), 
put_mem(D,E,A). 

/# INX D #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

DE is 256 # D + E + 1, 

D1 isDE H 256, 

El is DE mod 256, 

asserta(state(regs(A,B,C,D1,El,H,L),PC,SP,Flags)). 

reg_math( inc,d), I. /#INRD«/ 

reg_math(dec,d), l. /#DCRD#/ 

/#MVID, data#/ 

retract(state(regs(A,B,C,_,E,H,L),PC,SP,Flags)), 
memory(PC,D), 

NewPC is PC +1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 


continued 


BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 57 



August 


op(23) /* RAL */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))), 

A1 is (2 * A + CY) mod 256, 

NewCY is A mod 128, 

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,NewCY,AC))). 

op(25) /*DADD*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), 

NewL is L + E, 

Carry is NewL // 256, 

NewH is H + D + Carry, 

CY is NewH// 256, 

FL is NewL / \ 255, 

FH is NewH / \ 255, 

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))). 

op(26) /* LDAXD */ 

retract(state(regs(_,B,C,D,E,H,L),PC,SP,Flags)), 
get_mem(D,E,A), 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)). 

op(27) /* DCX D*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

DEis 256#D + E-1, 
decompose(DE,D1,El), 

asserta(state(regs(A,B,C,Dl,E1,H,L),PC,SP,Flags)). 

op(28) reg_math(inc,e),!. /* INR E »/ 

op(29) reg_jnath(dec,e),!. /#DCRE#/ 

op(30) /# MVI E, data */ 

retract(state(regs(A,B,C,D,_,H,L),PC,SP,Flags)), 
get_mem(PC,E), 

NewPC is PC + 1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(31) /*RAR»/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))), 

A1 is (A//2) + (128 *CY), 

NewCY is A mod 2, 

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,NewCY,AC))). 

op(32) /# RIM (read interrupt mask) #/ 

not_implemented. 


op(33) /# LXI HL #/ 

retract(state(regs(A,B,C,D,E,_,_),PC,SP,Flags)), 
get_mem(PC,L), 

Hi is PC + 1, 
get_mem(Hi,H), 

NewPC is PC + 2, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(34) I* SHLD (store H L direct) #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 
get_mem(PC,Lo), NextPC is PC 1, 

get_mem(NextPC,Hi), 

put_mem(Hi,Lo,L), NextLo is Lo + 1, 

put_mem(Hi,NextLo,H), 

NewPC is PC+ 2, 

asserts(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(35) /# INX H #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

HL is 256 * H + L + 1, 
decompose(HL,Hl,Ll), 

asserta(state(regs(A,B,C,D,E,Hl,Ll),PC,SP,Flags)). 
op(36) reg_math(inc,h),!. /#INRH*/ 

op(37) reg_math(dec,h),!. /*DCRH*/ 
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op(38) /* MVI H, data*/ 

retract(state(regs(A,B,C,D,E,_,L),PC,SP,Flags)), 
get_mem(PC,H), 

NewPC is PC +1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 


op(39) /*DAA*/ 

state(regs(A,B,C,D,E,H,L)flags(Z,S,P,CY,AC)), 
LSB is A/\ 15, 

LSB > 9; 

AC is 1, !, retract(state(_,PC,SP,F)), 

NewA is A + 6, 

asserta(state(regs(NewA,B,C,D,E,H,L),PC,SP,F)), 

MSB is NewA / \ 240, 

MSB >9; 

CY is 1, !, retract(_,PC,_,_), 

FinalA is NewA + 6, 

asserta(state(regs(FinalA,B,C,D,E,H,L),PC,SP,F)). 


op(4l) /# DAD H */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), 
NewL is L + L, % sum L plus lo-order register 

Carry is NewL / / 256, % Carry is one if NewL > 255 

NewH is H + H + Carry, % sum H with hi-order register 

CY is NewH // 256, % CY flag is one if NewH > 255 

FL is NewL /\ 255, t bring into byte range 

FH is NewH / \ 255, % this one too 

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))). 


op(42) /# LHLD (load HL direct) */ 

retract(state(regs(A,B,C,D,E,_,_),PC,SP,Flags)), 
get_mem(PC,Lo), NextPC is PC + 1, 

get_mem(NextPC,Hi), 

get_mem(Hi,Lo,L), NextLo is Lo+1, 

get_mem(Hi,NextLo,H), 

NewPC is PC+ 2, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(43) /* DCX H */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

HL is 256 * H + L - 1, 
decompose(HL,Hl,Ll), 

asserta(state(regs(A,B,C,D,E,Hl,Ll),PC,SP,Flags)). 


op(44) reg_math(inc,l),I. /* INR L#/ 

op(45) reg_math(dec,l),!. /* DCR L */ 

op(46) /* MVI L, data*/ 

retract(state(regs(A,B,C,D,E,H,_),PC,SP,Flags)), 
get_mem(PC,L), 

NewPC is PC -f 1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(47) /* CMA (complement accumulator) */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 
bit_xor(A,255,NewA), 

asserta(state(regs(NewA,B,C,D,E,H,L),PC,SP,Flags)). 

op(48) /* SIM (set interrupt mask) */ 

not_implemented. 


op(49) /* LXI SP */ 

retract(state(Regs,PC,_,Flags)), 
get_mem(PC,SPL), 

Hi is PC + 1, 
get_mem(Hi,SPH), 

SP is 256 * SPH + SPL, 

NewPC is PC+ 2, 

asserta(state(Regs,NewPC,SP,Flags)). 
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op(50) 


/* STA Adr (store accumulator in address) */ 
retract(state(regs(A, B, C, D, E, H, L), PC,SP,Flags)), 


get_mem(PC,Lo), 
get_mem(HiAdr, Hi), 
put_mem(Hi,Lo,A), 
NewPC is PC+ 2, 


HiAdr is PC + 1, 


asserts(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 


op(51) 


/* INXSP */ 


retract(state(Regs,PC,SP,Flags)), 

NewSP isSP + 1, 

check_overflow(NewSP,FinalSP), 
asserts(state(Regs,PC,FinalSP,Flags)). 


op(52) 


/* INR M #/ 


retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(_,_,_,CY,_))), 
get_mem(H,L,Data), 

NewData is Data + 1, 

adj ust_flags(A,NewData,FinalData,flagsl(Z,S,P,_,AC)), 
put_mem(H,L,FinalData), 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))). 

op(53) /# DCR M #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(_,_,_,CY,_))), 
get_mem(H,L,Data), 

NewData is Data - 1, 

adj ust_flags(A,NewData,FinalData,flagsl(Z,S,P,_,AC)), 
put_mem(H,L,FinalData), 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))). 

op(54) /# MVI M, data*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 
get_mem(PC,Data), 
put_mem(H,L,Data), 

NewPC is PC + 1, 

asserts(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(55) /* STC (set carry) */ 

retract(state(Regs,PC,SP,flags(Z,S,P,_,AC))), 
asserts(state(Regs,PC,SP,flags(Z,S,P,1,AC))). 

op(57) I* DAD SP */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), 
decompose(SP,SPH,SPL), 

NewL isL + SPL, 

Carry is NewL//256, 

NewH is H + SPH + Carry, 

CY is NewH//256, 

FL is NewL/\ 255, 

FH is NewH / \ 255, 

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))). 

op(58) I* LDA Adr #/ 

re tract (state (regs (_, B, C, D, E, H, L), PC, SP, Flags)), 
get_mem(PC,Lo), 

NextPC is PC + 1, 
get_mem(NextPC,Hi), 
get_mem(Hi,Lo,A), 

NewPC is PC+ 2, 

asserta(s tate(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(59) /*DCXSP*/ 

retract(state(Registers,PC,SP,Flags)), 

NewSP is SP - 1, 

check_overflow(NewSP,FinalSP), 

asserta(state(Registers,PC,FinalSP,Flags)). 

op(60) reg_jnath(inc,a), 1. /# INR A #/ 

op(6l) reg_math(dec,a),!. /*DCRA#/ 

op(62) /* MVI A, Data */ 

retract(state(regs(_,B,C,D,E,H,L),PC,SP,Flags)), 
get_mem(PC,A), 

NewPC is PC + 1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 
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op(63) /# CMC (complement carry) */ 

retract(state(Regs,PC,SP,flags(Z,S,P,CY,AC))), 
bit_xor(l,CY,NewCY), 

asserta(state(Regs,PC,SP,flags(Z,S,P,NewCY,AC))). 


op (Code) /# MOV Destination, Source #/ 

Code > 63, Code < 128, 

B210 Is Code / \ 7, % decode which reg is in bits 0-2 

B543 is (Code / \ 56) » 3, % do same for bits 3-5 

reg_ptr(B210,S), 
reg_ptr(B543,D), 
move(S,D). 


op(128) 

acc_math(+,b),! 

op(129) 

acc_math(+,c),! 

op(130) 

acc_math(+,d),! 

op(131) s- 

acc_jnath(+,e),! 

op(132) 

acc_math(+,h),! 

op(133) 

acc_math(+,l),! 

op(134) 



retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(H,L,Q), 

X is A + Q, 

adJust_flags(A,X,Y,Flags), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)). 


op(135) s- 

acc_math(+,a),!. 

op(136) 

acc_math_with_carry(+,b),! 

op(13?) 

acc_math_with_carry(+,c),! 

op(138) 

acc_math_with_carry(+,d),I 

op(139) 

acc_math_with_carry(+,e),! 

op(l40) 

acc_math_with_carry(+,h),l 

op(l4l) 

acc_math_with_carry(+,l),! 

op(l42) 



retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(H,L,Q), 

X is A + Q, 

adJust_flags(A,X,Y,Flags), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)). 


op(l43) 

acc_math_with_carry(+,a),! 

op(l4<) 

acc_math(-,b),!. 

op(l45) 

acc_math(-,c),!. 

op(l46) 

acc_math(-,d),!. 

op(147) !- 

acc_math(-,e),!. 

op(l48) 

acc_math(-,h),!. 

op(l49) 

acc_math(-,l),!. 

op(150) 



retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(H,L,Q), 

X is A + Q, 

adj ust_flags(A,X,Y,Flags), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)). 


% add B with carry 


op(l51) acc_math(-,a),!. 


continued 


BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 61 







August 


op(152) 

acc_math_with_carry(-,b),! 

op(153) 

acc_jnath_with_carry(-,c),! 

op(1^4) 

acc_math_with_carry(-,d),! 

op(l55) 

acc_math_with_carry(-,e),! 

op(156) 

acc_math_with_carry(-,h),! 

op(157) 

acc_math_with_carry(-,l),! 

op(158) 



retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(_,_,_,CY,_))), 
get_mem(H,L,Q), 

X is A-Q-CY, 

adjust_flags(A,X,Y,Flags), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)). 


op(159) 

acc_math_with_carry(-,a),! 

op(l60) 

acc_math(/\,b),!. 

op(l6l) 

acc_raath(/\,c),I. 

op(162) 

acc_math(/\,d),!. 

op(163) 

acc_math(/\,e),!. 

op(l64) 

acc_math(/\,h),!. 

op(165) 

acc_math(/\,1 ),!. 

op(l66) 



retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(H,L,M), 

X is A / \ M, 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,l))). 

op(167) % AND A (affects flags) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
adJust_flags(A,A,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,l))). 

op(l 68 ) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
bit_xor(A,B,X), 

adJust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(169) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
bit_xor(A,C,X), 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(170) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
bit_xor(A,D,X), 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(171) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
bit_xor(A,E,X), 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(172) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,__)), 
bit_xor(A,H,X), 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 
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op(173) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
bit_xor(A,L,X), 

adJust_flags(A l X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(174) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 

get_mem(H,L,M), 

bit_xor(A,M,X), 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP # flags(Z,S,P,0,0))). 

op(175) 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
bit_xor(A,A,X), 

adjust_flags(A,X,Y, flags (Z,S,P,_,__)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 


op(l76) 

acc_jnath(/\ ,b),!. 


op(177) 

acc_math(/\,c),!. 


op(178) 

acc_math(/\,d),1. 


op(179) 

acc_math(/\,e),!. 

/a ORA E a/\ 

op(180) 

acc_math(/\,h),!. 

/a ORA Ha/ 

op(181) 

op(182) 

acc_math(/\,l),!. 



retract(state(regs(A,B,C,D l E,H,L),PC,SP,_)), 
get_mem(H,L,M), 

X is A / \ M, 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(183) 

retract(state(regs(A,B,C,D # E,H,L),PC # SP,_)), 
adjust_flags(A,A,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 


op(184) 

comp_regs(b),!. 

/a CMP B a/ 

op(185) 

comp_regs(c),!. 

/a CMP C a/ 

op(186) 

comp_regs(d),!. 

/a CMP Da/ 

op(187) 

comp_regs(e),I. 

/a CMP E a/ 

op(188) 

comp_regs(h),!. 

/a CMP H*/ 

op(189) 

comp_regs(l),!. 

/a CMP La/ 

op(190) 

/a CMPM a/ 



retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_jnem(H,L,Q), 

X is A-Q, 

adJust_flags(A,X,_,Flags), 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)). 

op(191) /a CMP A a/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
adJust_flags(A,0,_,Flags), 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)). 

op(192) /a RNZ */ 

(not zero_flag_is_set, return); true. 

op(193) /» POPB a/ 

retract(state(regs(A,_,D,E,H,L),PC,SP,Flags)), 
get_jnem(SP,C), 

Hi is SP 4-1, 
get_mem(Hi,B), 
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op(194) 

NewSP isSP + 2, 

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)). 

/*JNZ*/ 

(not zero_flag_is_set, jump); carry_on. 

op(195) 

/# JMP #/ 

Jump. 

op(196) 

/#CNZ*/ 

(not zero_flag_is_set, call); carry_on. 

op(197) 

/# PUSH B #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

Hi is SP-1, 
put_mem(Hi,B), 

Lois SP-2, 
put_mem(Lo,C), 

NewSP isSP-2, 

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)). 

op(198) 

/# ADI D8 */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(PC,Q), 

XisA + Q, 

ad j us t_f lags (A, X, Y, Flags), 

NewPC is PC + 1, 

asserta(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(199) 

/*RST0*/ 

reset(0). 

op(200) 

/* RZ */ 

(zero_flag_is_set, return); true. 

op(201) 

/*RET*/ 

return. 

op(202) 

/*JZ#/ 

(zero_flag_is_set, Jump); carry_on. 

op(204) 

/* CZ */ 

(zero_flag_is_set, call); carry_on. 

op(205) 

/# CALL #/ 

call. 

op(206) 

1* ACIDS *1 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flagsCY,_))), 
get_mem(PC,Q), 

X is A + Q + CY, 

adj ust_flags(A,X,Y,Flags), 

NewPC is PC + 1, 

asserts(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(207) : 

/*RST1#/ 

reset(1). 

op(208) : 

/* RNC */ 

(not carry_flag_is_set, return); true. 

op(209) : 

/*P0PD*/ 

retract(state(regs(A,B,C_,_,H,L),PC,SP,Flags)), 
get_mem(SP,E), 

Hi is SP + 1, 
get_mem(Hi,D), 

NewSP isSP + 2, 

asserts(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)). 

op(210) : 

/#JNC#/ 

(not carry_flag_is_set, Jump); carry_on. 

op(211) : 

/ * OUT * / 

not_implemented. 
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op(212) /* CNC */ 

(not carry_flag_is_set, call); carry_on. 

op(213) /# PUSH D */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

Hi is SP-1, 
put_jnem(Hi,D), 

Lo is SP-2, 
put_jnem(Lo,E), 

NewSP is SP-2, 

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)). 

op(214) /*SUID8*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(PC,Q), 

X is A-Q, 

ad j ust_flags(A,X,Y,Flags), 

NewPC is PC + 1, 

asserta(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(215) /# RST2 # / 

reset(2). 

op(2l6) /« HC */ 

(carry_flag_is_set, return); true. 

op(218) l*JC*l 

(carry_flag_is_set, jump); carry_on. 

op(219) /* IN */ 

not_implemented. 

op(220) /* CC */ 

(carry_flag_is_set, call); carry_on. 

op(222) /* SBI #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flagsCY,_))), 
get_mem(PC,Q), 

XisA-Q-CY, 

adj ust_flags(A,X,Y,Flags), 

NewPC is PC + 1, 

asserta(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(223) /*RST3*/ 

reset(3). 

op(224) /* RPO odd parity; flag is 0 #/ 

(not parity_flag_is_set, return); true. 

op(225) /# POP H *1 

retract(state(regs(A,B,C,D,E,_,_),PC,SP,Flags)), 
get_mem(SP,L), 

Hi is SP + 1, 
get_mem(Hi,H), 

NewSP is SP + 2, 

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)). 

op(226) /*JPO odd parity; flag is 0*/ 

(not parity_flag_is_set, Jump); carry.on. 

op(227) /# XTHL #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 
get_mem(SP,NewH), 
put_mem(SP,H), 

SP1 is SP + 1, 
get_mem(SPl,NewL), 
put_mem(SPl,L), 

asserta(state(regs(A,B,C,D,E,NewH,NewL),PC,SP,Flags)). 

op(228) /* CPO odd parity; flag is 0 »/ 

(not parity_flag_is_set, call); carry_on. 

op(229) /* PUSH H #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 

Hi is SP-1, 
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put_mem(Hi,H), 

Lo is SP-2, 
put_mem(Lo,L), 

NewSP is SP-2, 

asserts(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)). 

op(230) /* ANID8*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(PC,M), 

X is A/\ M, 

adj ust_flags(A,X,Y,Flags), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)). 

op(23l) /*RST4*/ 

reset(4). 

op(232) /# RPE odd parity; flag is 1#/ 

(parity_flag_is_set, return); true. 

op(233) /*PCHL*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 
decompose (PC, PCH, PCL), % (i,o,o) 
decompose (NewPC,H,L), fc(o,i,i) 

asserta(state (regs(A, B, C, D, E, PCH, PCL), NewPC,SP, Flags)). 

op(234) /* JPE odd parity; flag is 1 #/ 

(parity_flag_is_set, Jump); carry_on. 

op(235) i- /# XCHG#/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), 
asserta(state(regs(A,B,C,H,L,D,E),PC,SP,Flags)). 

op(236) /# CPE odd parity; flag is 1 #/ 

(parity_flag_is_set, call); carry_on. 

op(238) :- /*XRID8*/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 

get_mem(PC,M), 

bit_xor(A,M,X), 

adjust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(239) /* RST 5 */ 

reset(5). 

op(240) I* RP sign flag is 0 #/ 

(not sign_flag_is_set, return); true. 

op(24l) /* POPPSW */ 

retract(state(regs(_,B,C,D,E,H,L),PC,SP,_)), 
get_mem(SP,Flags), 

Hi is SP + 1, 
get_mem(Hi,A), 

NewSP is SP + 2, 

Sis (Flags/\ 128) / 128, 

Z is (Flags /\ 64) / 64, 

AC is (Flags/\ 16) / 16, 

P is (Flags /\ 4)/ 4, 

CY is Flags/\ 1, 

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,flags(Z,S,P,CY,AC))). 

op(242) <* JP sign flag is 0 */ 

(not sign_flag_is_set, jump); carry_on. 

op(243) /*DI#/ 

not_implemented. 

op (244) j * CP sign flag is 0 */ 

(not sign_flag_is_set, call); carry_on. 

op(245) /* PUSH PSW */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))), 

Hi is SP-1, 
put_mem(Hi,A), 

Lo is SP-2, 
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Flags isCY*l + P*4 + AC*l 6 + Z*64 + S# 128, 
put_mem(Lo,Flags), 

NewSP isSP-2, 

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,flags(Z,S,P,CY,AC))). 

op(246) /*0RID8#/ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(PC,M), 

X is A/\ M, 

adj ust_flags(A,X,Y,flags(Z,S,P,_,_)), 

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))). 

op(247) /# RST 6 */ 

reset( 6 ). 

op(248) /* RM sign flag is 1 foj 

(sign_flag_is_set, return); true. 

op(249) /* SPHL #/ 

retract(state(regs(A,B,C,D,E,H,L),PC,Flags)), 
decompose (SP,H,L), *(o,i,i) 

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)). 

op(250) /# JM sign flag is 1 */ 

(sign_flag_is_set, jump); carry.on. 

op(251) /* El */ 

not_implemented. 

op(252) /* CM sign flag is 1 #/ 

(sign_flag_is_set, call); carry_on. 

op(254) /* CPI D 8 */ 

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), 
get_mem(PC,Q), 

X is A - Q, 

adj ust_flags(A,X,Y,Flags), 

NewPC is PC 1, 

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)). 

op(255) /* RST 7 # / 

reset(7). 

op(_) write( 'undefined opcode'), nl. 

% 

*end: OPS8085.ARI 


HELP80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


% File: HELP80.ARI 

% 

% "nondestructive" help - saves the screen while you access help info. 

% 

% There's nothing here that can't be done with most Prolog implementations; here, we use Arity's region_ca/\3> 

% tget/2, and tmove/3 predicates to save the screen, save the cursor position, and restore the cursor position. 

% If your Prolog doesn't implement these features, they can be excised with no great harm done. 

% 

% Arity/Prolog encloses strings within '$' characters, so this part may require some minor rewrite to work with other 
% Prolog implementations. 

% 

% 

help grab(S,R,C),write($HELP 

Commands can be entered as one or two unique letters (' t' for ' trace', f sh' 
for ' show'), or as complete words (' step'). 

All numbers input by the user are assumed to be base 16 (hexadecimal) numbers. This means, for example, that the 
command 'step 10' is a request for 16 steps, not 101 
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Hexadecimal numbers that start with a letter must be typed in with a 
leading zero (e.g., ' ff' must be typed in as 'Off ). 

Additional help is available for the following commands: 

status change trace quit 

show reset step 

To get additional help, type 'help 1 and the command word you are interested in. 

$), let_go(S,R,C). 

help(status) grab(S,R,C),write($STATUS 

This command prints the state/4 clause to the screen. The information displayed by state/4 is not as "pretty' 1 as that shown by 
the 'show' command, but is complete. 

$), let_go(S,R,C). 

help(help) :-help. 

help(show) grab(S,R,C),write($SHOW 

Use this command to display the contents of a register, of a register-pair pointer, and of memory. 

To display the contents of a register or of a register pair, type 'show' followed by the appropriate name. 

If no parameters are supplied, 16 bytes of memory are shown starting at the current PC value. If only one memory address 
is specified, only the contents of that address will be displayed. 

Examples: 

show b Show contents of register b 

show be Show contents of address pointed to by be 

show Show contents of PC through PC + 16 (decimal) 

show 0020 Show contents of address 0020 

show 0020 002f Show contents of addresses 0020 through 002f 

$), let_go(S,R,C). 

help(change) :- grab(S,R,C),write($CHANGE 

Use this command to change the contents of a register, of an address in memory, or of an address pointed to by a 16-bit register. 

To change something, type 'change' followed by the appropriate register name or memory location, followed in turn by 
the new value. 

Examples: 

change 002c 3f Changes the contents of address 002c to 3f 

change d 2c Changes the contents of register d to 2c 

change pc 0f3 Changes the contents of the program counter to 0f3 

$), let_go(S,R,C). 

help(reset) grab(S,R,C),write($RESET 

This command resets everything back to the initial state: 

state(regs(0,0,0,0,0,0,0),0,255,flags(0,0,0,0,0)) 

$), let_go(S,R,C). 

help(step) :- grab(S,R,C),write($STEP 

This command causes an instruction to be executed. Multiple instructions can be stepped by adding a second, numeric argument. 
Examples: 

step Steps through one instruction 

step 3 Steps through three instructions 

step 10 Steps through 16 instructions 

$), let_go(S,R,C). 

help(my_trace) :- grab(S,R,C),write($TRACE 
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Like 'step', this command causes one instruction to be executed, but also displays the processor state upon completion. 
Multiple traces can be performed by adding a second, numeric argument. 

Examples: 


trace Steps through an instruction and shows all 

trace 3 Steps and shows all through three instructions 

trace 10 Steps and shows all through 16 instructions 

$), let_go(S,R,C). 

help(quit) grab(S,R,C),write($QUIT 

This command brings you back to Prolog's '?-' prompt. 

$), let_go(S,R,C). 

% 

% grab/1 takes advantage of an Arity/Prolog predicate that reads characters and their attributes from the screen and places 
% them in a string. This in effect saves the screen while you are off getting help. 

% 

% let_go/l waits for the user to strike a key and then restores the screen to the way it looked before the help session. 

% 

% if you don't mind losing the screen contents when you seek help, you can dispense with these predicates. 

% 

grab(S,R,C) : — tget(R,C), 

region_ca( (0,0), (24,79), S), 
els, !. 

let_go(S,R,C) write($Strike a key to continue ... $), 
getO(Ch), 
els, 

region_ca( (0,0), (24,79), S), 
tmove(R,C), !. 


% end 


PREDS80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


% Subject: PREDS80.ARI - from Alex Lane: "Simulating a Microprocessor" 

% bit_xor(A,B,C) :: C is exclusive-or of A and B 

% 

bit_xor(0,0,0) :- !. 

bit_xor(0,l,l) !. 

bit_xor(l,0,l) !. 

bit_xor(1,1,0) :- 1. 

bit_xor(A,B,X) :- 

AA0 is A / / 2, A0 is A mod 2, 

BB0 is B / / 2, B0 is B mod 2, 

bit_xor(AA0,BB0,XX0), 
bit_xor(A0,B0,X0), 

X is 2 # XX0 + X0. 

% adjust_flags( In, Out, flags(Z,S,P,CY,AC)) :: In —> Out and flags checked. 

* 

adJust_flags(A,In, Out, flags(Z,S,P,CY,AC)) 
check_carry( In, Out, CY ), 
check_zero(0ut,Z), 
check_parity(Out,P), 
check_aux_carry(A,Out,AC), 
check_sign(Out,S). 

X carry_on :: PC <— PC + 2. 

% 
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carry_on 

retract(state(Regs,PC,SP,Flags)), 

NewPC is PC+ 2, 

asserta(state(Regs,NewPC,SP,Flags)). 

% check_zero(A,B) :: A == 0 —> B == 1, else B == 0. 

% 

check_zero( 0 ,l) !. 
check_zero(_, 0 ). 

% check_parity(X,Y) :: Y reflects odd parity of number of bits inX. 

check_parity(X, Y) par(X,T), Y is T mod 2, !. 

par( 0 , 0 ) !. 

par(l,l) 

par(N,P) :-J is N mod 2, 

K is N / / 2, 
par(K,Pl), 

P is J + Pl. 

check_sign(X,l) :-X>127, !. 
check_sign(_, 0 ). 

check_carry(In,Out,l) In > 255# Out is In - 255# !. 
check_carry(In,Out,l) :-In<0, Out is In+ 255, !. 
check_carry(In, ln, 0 ). 

check_aux_carry(01dAccum, NewAccum, 1) 

OldAccum / \ 24 =: = 8, % old bit 3 on and old bit 4 off 

NewAccum /\ 24 *:■ 16,1. % new bit 4 on and new bit 3 off 

% (=: = evaluates both sides and tests for equality) 


check_aux_carry(_,_, 0 ) I. 
zero_flag_is_set 

state(_,_,_, flags( 1 ,), ! • 
sign_flag_is_set 

state(_,__, — , flags 1 ,), I • 

parity_flag_is_set 
pstate(_,_,_,flags(_,_,l,!. 

carry_flag_is_set 

state(_,_,_,flags(_,_,_,l,_)), !. 

aux_carry_flag_is_set 

state(_,_,_,flags(_, 1 )), !. 

% reset (N) :: store PC on stack, PC <-- 8 * N. 

% 

reset(N) 

retract(state(Registers,PC,SP,Flags)), 
decompose(PC,PCH,PCL), 

Hi is SP-1, 
put_jnem(Hi,PCH), 

NewSP is SP - 2, 
pu t_jnem (NewSP, PCL), 

NewPC is 8 * N, 

asserta(state(Registers,NewPC,NewSP,Flags)). 

% return :: pop PC off stack, adjust SP. 

% 

return 

retract(state(Registers,_,SP,Flags)), 
get_mem(SP,PCL), 

Hi is SP + 1, 
get_mem(Hi,PCH), 

PC is 256 * PCH + PCL, 

NewSP isSP + 2, 

asserta(state(Registers,PC,NewSP,Flags)). 
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jump 

retract(state(Registers,PC,SP,Flags)), 
get_mem(PC,PCL), 

Hi is PC + 1, 
get_jnem(Hi,PCH), 

NewPC is 256 * PCH + PCL, 

asserta(state(Registers,NewPC,SP,Flags)). 


call 

retract(state(Registers,PC,SP,Flags)), 

PCNisPC + 2, X here? or on return? 

PCH is PCN / / 256, 

PCL is PCN mod 256, 

SP1 is SP - 1, 

SP2 is SP - 2, 
put_mem(SPl,PCH), 
put_mem(SP2,PCL), 
get_mem(PC,NPCL), 

Hi is PC + 1, 
get_mem(Hi,NPCH), 

NewPC is 256 * NPCH + NPCL, 
asserta(state(Registers,NewPC,SP2,Flags)). 

% put_mem( H, L, Data) :: store Data in Address <— 256 # H + L. 

% 

put_mem( Hi, Lo, NewData ) 

Address is 256 * Hi + Lo, 
put_mem(Address, NewData). 

X put_mem( H, L, Data) :: store Data in Address. 

% 

put_mem(Address,NewData) 

retract(memory(Address,_)), 
asserta(memory(Address,NewData)). 

X getjnem( H, L, Data) :: fetch Data in Address <~ 256 * H + L. 

X 

get_mem(Hi, Lo, Data ) 

Address is 256 * Hi + Lo, 
get_mem(Address,Data). 

X get_mem( Address, Data) :: fetch Data in Address. 

X 

get_mem(Address, Data) 

memory(Address,Data). 

X decompose (Address, Hibyte, Lobyte) :: Address <— 256 # Hibyte + Lobyte 

X (o,i,i) 

X 

decompose (Address, Hibyte, Lobyte) : - X (o, i, i) 

var(Address), X if Address is uninstantiated 

Address is 256 # Hibyte + Lobyte. 

X decompose (Address, Hibyte, Lobyte) :: Address --> Hibyte ; Lobyte 

X (i,o,o) 

X 

decompose (Address, Hibyte, Lobyte) *(i,o,o) 

F is Address / 256, 

H is integer(F), 

Hibyte isH/\ 255, 

G is Address - 256 # H, 

Lobyte is integer(G). 

put_address(Lo) X write an address in hex 

decompose(Lo,LoH,LoL), 
dec_hex_byte(LoH,LHH), 
dec_hex_byte(LoL,LLH), 
write(LHH),write(LLH),write(' : •),!. 


continued 
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% Decimal-to-hex and hex-to-decimal conversions. 


dec_hex_byte( Dec, Hex ) :- % (i,o) 

var(Hex),!, 

Dec < 256, 

Hi is Dec >> 4, 

Lois Dec /\ 15, 

d_h(Hi,H), 

d_h(Lo,L), 

list_text([H,L],Hex). 

dec_hex_byte( Dec, Hex ) % (o,i) 

list_text([H,L],Hex), 
d_h(Hi,H), 
d_h(Lo,L), 

Dec is 16 # Hi + Lo,!. 

d_h( In, Out) % (i,o) 

In< 10 , 

Out is In + 48. 

d_h( In, Out) % (i,o) 

Out is In + 55. 

d_h( Out, In ) :- % (o,i) 

In <65, 

Out is In - 48. 

d_h( Out, In ) *(o,i) 

In <71, 

Out is In - 55. 

min(II,II, 12) II =< 12, !. 

min(I2,Il,I2) :-I2< II. 


for(X,X,X) :- !. 
for(X,Y,X). 

for(X,Y,Z) XI isX + 1, for(Xl,Y,Z). 

append([H | T], L, [H | R]) :-!, append(T, L, R). 
append([ ], L, L). 

valid_adr(H,L) top_of_memory(TOM), TOM >= (256 # H + L). 

reg(a,l). reg(b,2). reg(c,3). reg(d,4). 

reg(e,5). reg(h,6). reg(l,7). 

fl(z,l). fl(s,2). n(p,3) . fl(cy,4). fl(ac,5). 

% 

% end: PREDS80.ARI 


PARSE80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


% Subject: PARSE80.ARI - from Alex Lane: "Simulating a Microprocessor" 

% Use DCG to parse a command (request) from the simple monitor. 

% 

% Intended to be used with TOKENS. ARI (5/10/86) 

% 

% Basically want to implement following commands: 

% 

% 

% change memory-address-value 

% +— register-contents-value 

% +— register-pair-pointer-value 

% help (a screen of help) 

% quit (back to DOS) 

% reset (all parameters to some intial state) 


Examples: 

(change 002 c 30 
(change d 2 c) 
(change pc 0 f 3 ) 
(help) 

(quit) 

(reset) 
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% show —+— register-contents 
% +— contents of register-pair-pointer 

t +— <memory, no range specified 

% +— starting-memory-address 

% +— starting-address — ending-address 

% step 
% trace 
% 


(show b) 

(show be) 

(show) 

(show 0020) 
(show 0020 002f) 
(step) 

(trace) 


parse_tokens(change(Adr,Val)) —> verb(change), address(Adr), byte(Val). 

parse_tokens(change(Reg,Val)) —> verb(change), register_name(Reg), byte(Val). 

parse_tokens(change(RegPair,Val)) —> verb(change), pointer(RegPair), byte(Val). 

parse_tokens( change (Flag, Value)) —> verb(change), flag(Flag), flag_value (Value). 

parse_tokens( show (Reg)) — > verb(show), register_name(Reg). 

parse_tokens( show (Group)) —> verb(show), group_des ignat ion (Group). 

parse_tokens(show(RegPair)) —> verb(show), pointer(RegPair). 

parse_tokens (show (Start, End)) —> verb(show), address (Start), address(End), 

{ Start =< End } . 

parse_tokens( show (Start)) — > verb(show), address (Start). 

parse_tokens(help(Topic)) —> verb(help), verb(Topic). 

parse_tokens( step (Times)) — > verb(step), byte(Times). 

parse_tokens(my_trace(Times)) — > verb(my_trace), byte(Times). 

parse_tokens(Command) —> verb(Command), { Command \ = = change }. 

address(Adr) —> [Adr], { Adr>= 0, top_of_memory(TOM), Adr =< TOM }. 

byte(Val) —> [Val], { Val >* 0, Val <256 }. 

flag_value(X) —> [X], { X == 1; X == 0 }. 

register_name(a) —> [a]. register_name(b) —> [b], 

register_name(c) — > [c]. register_name(d) —> [d]. 

register_name(e) —> [e]. register_name(h) —> [h]. 

register_name(l) —> [1], register_name(flags) —> [f];[fl];[flags]. 

flag(z) —> [z]. flag(s) —> [s]. flag(p) —> [p]. 

flag(cy) —> [cy]. flag(ac) —> [ac]. 

group_designation(all) — > [al];[all]. 
group_designation(regs) — > [r]j[re];[regs]. 
group_designation(stack) —> [st];[stack]. 

pointer(bc) —> [be]. pointer(de) —> [de]. 

pointer(pc) —> [p];[pc]. pointer(sp) —> [s];[sp]. 
pointer(hl) —> [hi];[m];[me];[mem]. 

verb(change) —> [c];[ch];[change];[set]. % ’set' is a synonym 

verb(status) —> [state]. % must say 'state' 

verb(help) —> [h];[he];[help]. 

verb(quit) —> [q];[qu];[quit]. 

verb(show) —> [sh];[show], 

verb(step) —> [st];[step], 

verb(my_trace) —> [t];[tr];[trace]. 

verb(reset_processor) — > [r];[re];[reset]. 

% end PARSE80.ARI 


continued 
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MON80. ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 

% Subject: M0N80.ARI - from Alex Lane: "Simulating a Microprocessor" 

% state(_) needs to have been asserted. 

% memory must be initialized (so we need 'memory').. 


quit :- write('Quitting.'), nl, abort. 

step :- step(l),!. 

step(N) :- for(l,N,X), execute_instruction, N == X, !. 

status :-state(R,P,S,F), write(state(R,P,S,F)), nl. 

my.trace :- my_trace(l). 

my_trace(N) for(l,N,X), execute_instruction, show(all), nl, N == X. 

reset_processor :- 

retract(state(_,), 

asserta(state(regs(0,0,0,0,0,0,0),0,254,flags(0,0,0,0,0))). 

change (Adr, Val) :- 

number(Adr),!, 
put_mem(Adr,Val). 

change (Reg, Val) :- 

reg(Reg,X),!, 
retract(state(R,P,S,F)), 
argrep(R,X,Val,NewR), 
asserta(state(NewR,P,S,F)). 

change(Flag, Val) :- 

fl(Flag,X),!, 
retract(state(R,P,S,F)), 
argrep(F,X,Val,NewF), 
asserta(state(R,P,S,NewF)). 


change(pc, P) :- 

!, retract(state(R,_,S,F)), 
asserta(state(R,P,S,F)). 


change(sp, S) :- 

!, retract(state(R,P,_,F)), 
asserta(state(R,P,S,F)). 


change(bc, Val) 

!, state(R, 

arg(2,R,B), arg(3,R,C), 

ifthen( valid_adr(B,C), put_mem(B,C,Val)). 


change(de, Val) :- 

!, state(R, 

arg(4,R,D), arg(5,R,E), 

ifthen( validLadr(D,E), put_mem(D,E,Val)). 


change (hi, Val) :- 

!, state(R,_,_,_), 

arg(6,R,H), arg(7,R,L), 

ifthen( valid_adr(H,L), put_mem(H,L, Val)). 


show(Reg) :- 

reg(Reg,X), 
state(R,_,_,_), 

arg(X,R,T), dec_hex_byte( T,HT), 

tab(l), concat( [Reg,' (',HT,')' ],Y) ,write(Y),!. 
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show(bc) 

state(R, 

arg(2,R,B), arg(3,R,C), 

ifthenelse( valid_adr(B,C), 

(get_mem(B,C,D), dec_hex_byte(D,DH)), 

DH = $xx$), 

concat(['bc>',DH,'< »],Y), 
write(Y), !. 

show(de) 

state(R,_,_,__), 
arg(4,R,D), arg(5,R,E), 

ifthenelse( valid_adr(D,E), 

(get_mem(D,E,Dl), dec_hex_byte(Dl,DH)), 

DH = $xx$) , 

concat(['de>',DH,'< '],Y), 
write(Y), !. 

show(hi) 

state(R, 

arg(6,R,H), arg(7,R,L), 

ifthenelse( valid_adr(H,L), 

(get_mem(H,L,D), dec_hex_byte(D,DH)), 

DH = $xx$), 

concat([ , hl>’,DH,'< ’]# Y )# 
write(Y), !. 

show(pc) 

state(_,P,_,_), dec_hex_byte(P,PH), 
concat(['pc>',PH,'< ']»Y), 
write(Y), !. 

show(sp) 

state(_,_,S,_), dec_hex_byte(S,SH), 
concat([’sp>’,SH,'< »],Y), 
write(Y), 1. 

show(regs) 

% show registers and pointers 

show(a), show(b), show(c), show(d), show(e), show(h), show(l), 
write(': ')# show(bc), show(de), show(hl), show(pc), show(sp). 

show(all) 

% show registers, pointers, and flags 
show(regs), 
nl, show(flags). 

show(flags) 

% show flags only. 

state(_,_,_,flags(Z,S,P,CY,AC)), 

write(' z = 1 ) ,write(Z), write(»; s » '), write(S), 
write( 1 ; p = '), wrlte(P), write('; cy = '), write(CY), 
write( f ; ac = '), write(AC). 

show(stack) 

state(_,_,S,_), SI is S + 15, 
top_of_memory(TOM), min(S2,Sl,T0M), 
show(S,S2). 

show(Mem) 

% show a single memory location's contents. 
show(Mem, Mem),!. 

show 

% starting with current PC address, show 16 bytes. 
state(__,P,_,J, 

top_of_memory(TOM), T0M_1 is TOM - 1, 

End is P + 15, min(Q,TOH_l, End), 
show(P,Q),!. 

show(Lo, Hi) 

% show specified memory range. 
number(Lo), number(Hi), 

Diff isHi-Lo + 1, 
show_mem(Diff, Lo),!. 

show_mem(0,_) 

!. 
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show_mem(Left, Start) 

min(X,l6,Left), 

NewLeft is Left-X, 
put_address(Start), 

dec(X,XO), % because we are going to use zero indexing 

for(0,X0,Y), 

[! Adr is Start + Y, 
get_mem(Adr,Data), 
dec_hex_byte(Data,DH), 
write(DH),tab(l) !], 

XO == Y, nl, !, 

NewAdr is Start + X, 
show_mem(NewLeft,NewAdr). 

% 

% end: M0N80.ARI 


STARTUP.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 9: Standard startup source #/ 

/* startup.c #/ 
tfifdef HYPERC 

/ # Won 1 1 create window for us # / 

s tdTerm (PStr (" Hyper-C w indow ")); 
EXTERN CHAR getKey( ); 

^define getchar() getKey(TRUE) 
tfendif 

0ifdef MPU68000 

I* Aztec needs this #/ 

pascal long TickCount() = 0xa975; 

#endif 


I* Start timing #/ 
long time; 

puts("Press any key to begin timed test: "); 
getchar(); 

puts("\nStarting\n"); 
time = TickCount(); 


MEMORY.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


% File: MEMORY.ARI 

% 

% Note: 

% Since this file is very repetitious, only a small portion of the 
% file is represented here. 

% You can generate a complete copy of the file by running the 
% bas ic program MEMORY. BAS 

* 

t 

% 

% This file contains a predicate that initializes a 256-byte memory 
% (shades of the mid-70s!). 

% To "run" a program on the simulated microprocessor, insert the 
% appropriate machine code bytes into the memory locations 

% 

init_mem :- 

asserts(top_of_memory(255 )), 
assertz(memory(0,0)), % NOP 

assertz(memory(l,0)), % NOP 

assertz(memory(2,0)), % NOP 
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assertz(memory(3,0)), % NOP 

assertz(memory(4,0)), % NOP 

% ... 

assertz(memory(253>0)), % NOP 

assertz(memory(254,0)), % NOP 

assertz(memory(255,0)). % NOP 

% 

X end 


TOKENS80.ARI Contributed by Alex Lane. Accompanies the article ’’Simulating a Microprocessor," August 1987, page 161 


% Subject: T0KENS80.ARI - from Alex Lane: "Simulating a Microprocessor" 

% This version of get_token_list(_) assumes all input numbers are in 
% hexadecimal and delivers decimal numbers in the output; i.e., 

X entering 'show Of' results in [show, 15]. 


get_token_list(Result) 

read_line(0,String), 
list_text([Char|Tail],String), 
tokenize([Char|Tail], [], Result). 

% read a sentence from the terminal 
% read a line of input from the console 

tokenize([H|T],List,L) 

letter(H, Letter),!, 
restword(T,[Letter],Word,Rem), 
append(List,[Word],Nlist), 
tokenize(Rem,Nlist,L). 

X if head of list starts with letter 

X get the rest of a word 

X recurse, tokenize rest of list 

tokenize([H|T], List, L) 

digit(H),!, 

rest_num(T, [H] ,Num, Rem), 
append(List,[Num],Nlist), 
tokenize(Rem,Nlist,L). 

% if head of list starts with digit (0-9) 

% get a number (Num will be decimal) 

% recurse, tokenize rest of list 

tokenize([_|T], List, L) 

l, tokenize(T,List,L). 

X if head of list is not letter or digit, 

X ignore it. 

tokenize([],List,List). 

X stop recursion. 

restword( [H|T], List, Word, X ) 

letter( H, Letter ),!, 

append( List, [Letter], Nlist), 

restword( T, Nlist, Word, X ). 


restword( [32|T], List, Word, T ) :- 
name( Word, List ),!. 



restword( [_|T], List, Word, X ) :- 

!, restword( T, List, Word, X ) 


restword( [], List, Word, [] ) 

I, name( Word, List). 


rest_num( [H|T], List, Num, X ) :- 

hexdigit( H,_ ) , !, 
append( List, [H], Nlist ), 
rest_num( T, Nlist, Num, X ). 

X rest of number may have 0-9, a-f 

rest_num( [32|T], List, Num, T ) 

cname( Num, List, 0 ),!. 

X space finishes number, go convert. 

rest_num( [],List,Num,[]) 

!, cname(Num, List, 0). 

X nothing left, go convert. 

cname( F, [X|[]], N) 

!, hexdigit(X,Y), F is N + Y. 

X finished. 


continued 
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cname( Number, [H|T] ,In ) 

hexdigit(H,Hl), 

H2 is (In + HI) * 16, 
cname(Number, T, H2). 

letter(C, C) 

0=97, C =< 122, !. 

letter(C, D) 

0=65, C =< 90, !, 

DisC+ 32. 

hexdigit(D,E) 

digit(D), E is D - 48. 

hexdigit(D,F) 

letter(D,E), E >= 97, E =< 102, 

F is E - 87. 

digit(C) 

C >= 48, C =< 57. % 48 is "0", 57 is "9". 


% convert the input hex number to 
% a decimal. User need never know! 

% recurse with shorter list in T 

% 97 is "a", 122 is "z" 

% 65 is "A", 90 is "Z" 

% 32 is "a"-"A" 


% 

% end: T0KENS80.ARI 


MEMORY.BAS Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


10 ' Program to create MEMORY.ARI File for Prolog program 
20 ' for "Simulating a Microprocessor" 

30 ' by Alex Lane 
40 ' 

100 OPEN "MEMORY. ARI" FOR OUTPUT AS 1 
11OPRINT01, "% File: MEMORY.ARI" 

120 PRINT01, "% from Simulating a Microprocessor by Alex Lane" 
130 PRINTS, "%" 

140 PRINT01, This file contains a predicate that initializes" 
150 PRINTS, "* a 256-byte memory" 

160 PRINT01, "% To 'run' a program on the simulated microprocessor, 
170 PRINT01, "% insert the appropriate machine code bytes into 
180 PRINT01, "% the memory locations 
190 PRINT01, "*" 

200PRINT01, "init_mem 

210 PRINTS, " asserta(top_of_jnemory(255))," 

220 FOR I « 0 TO 254 
230 IS$ = STR$(I) 

240 PRINTS, " assertz(memory("; IS$; ",0)), % NOP" 

250 NEXT I 

26OPRINT01, " assertz(memory( 255,0)). % NOP" 

300 PRINTS, "*" 

310 PRINTS, "$ end" 

320 CLOSE 
400 END 


INTERFACED Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 6: Interface benchmark #/ 

^define HYPERC 
/* interface.c */ 

/# Modified by Joel West, April 14, 1987 for all systems #/ 

0include <stdio.h> 
fl if def HYPERC 
H vnclude <TBXTypes. h> 
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0include <events .h> 
ttelse 

ft ifdef MACC 
H include<macdefs.h> 

H include <events.h> 

H else 

H ifdef AZTEC 
H include<window.h> 

H inc lude < event. h> 

H else 
H ifdef LSC 

H include <EventMgr. h> 

H endif 
H endif 
H endif 
tfendif 

^define COUNT 10000 
main() 

{ int i, eMaskl, eMask2, booll, bool2; 

EventRecord eRcrdl, eRcrd2; 

^include "startup.c" 

eMaskl = eMask2 = -1; 
for (i* 0; i< COUNT; ++i) 

{ booll = GetNextEvent(eMaskl, &eRcrdl); 
boo 12 = GetNextEvent(eMask2, &eRcrd2); 

booll = GetNextEvent(eMaskl, &eRcrdl); 
boo 12 = GetNextEvent(eMask2, 8teRcrd2); 

booll = GetNextEvent(eMaskl, fceRcrdl); 
bool2 = GetNextEvent(eMask2, &eRcrd2); 

booll = GetNextEvent(eMaskl, &eRcrdl); 
bool2 = GetNextEvent(eMask2, &eRcrd2); 

} 

^include "done.c" 

} 


START80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161. 


% START80.ARI - from A. Lane: "Simulating an 8085 with Prolog" 

% This file starts everything up. 
go 

write( 'Loadingmemory. '),nl, 
consult(memory), 

vrite(' Initializing memory. ’) ,nl, 
init_mem, 

abolish(init_mem/0), 

write(' Loading monitor.'), nl, 

consult(mon80), 

write(' Loading command parser. ’) ,nl, 
consult(parse80), 
write(' Loading tokenizer.'), nl, 
consult(tokens80), 

write( ’ Loading miscellaneous routines.') ,nl, 
consult(preds80), 

write('Loadinghelp information'),nl, 
consult(help80), 

write(' Loading opcode predicates.') ,nl, 
consult(ops8085 ), 

asserta(state(regs(0,0,0,0,0,0,0),0,255 , flags(0,0,0,0,0))), 


con l i nurd 
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sign_on, 

monitor. 

% op(_) : - write(' instruction executed'). 

monitor 

repeat, 

prompt, 

get_token_list(Tokens), 

ifthenelse( parse, tokens (Command, Tokens, []), % run command thru DCG. if valid 
call(Command) , % do it, else 

write (* invalid request') ), {{tell user no. 

fail. 

execute.instruction 

retract(state(R,PC,SP,F)), 

NewPC is PC + 1, 

asserts(state(R,NewPC,SP,F)), 
get_mem(PC,Instruction), 
op(Instruction),!. 

sign_on 

els, 

write( *8085 simulator') ,nl, 
write($Type 'h' for help.$), nl. 

prompt 

tget(_,Col), % find out what column cursor's in. 

ifthen( Col \= 0, nl), % if cursor not in column 0, new line, 
write('-<'),!. % print prompt. 

% 

% end START80.ARI 


SIEVE.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 1: Sieve benchmark #/ 

/# sieve.c #/ 

^define LSC 

/* Eratosthenes Sieve prime number program from BYTE, January 1983 
Modified by Joel West, April 13, 1987, for 16-bit short 

*/ 

^define REGISTER 
^include <stdio.h> 

tfifdef HYPERC 
N inc lude <TBXTypes. h> 

^include <events.h> 
tfendif 

^define TRUE 1 
^define FALSE 0 
^define size 8190 


/# do program 10 times #/ 
/# prime counter #/ 
/# set all flags true #/ 


/# found a prime */ 


char flags [size + 1]; 
main() 

{ REGISTER short i, prime, k, count, iter; 

^include "startup.c" 

for (iter =1; iter <=10; iter++) 

{ count = 0; 

for (i ■ 0; i<= size; i++) 
flags [i] = TRUE; 

for(i = 0; i<=size; i++) 

{ If (flags [1]) 
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{ prime = 1 + i+ 3; /* twice index + 3 */ 

for (k = i + prime; k <= size; k+= prime) flags [k] = FALSE; /* kill all multiple #/ 

count++; / # primes found * / 

} 

} 

^include "done.c" 

} 


SORT.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/* Listing 4: Sort benchmark #/ 


/* sort.c #/ 

^define LSC 

/* sorting benchmark—calls randomly the number of times specified by MAXNUM to create an array of long integers, then does a 
quicksort on the array of longs. The program does this for the number of times specified by COUNT. 

Modified by Joel West, April 13, 1987, for 16-bit short 
*/ 

^include <stdio.h> 

tfifdef HYFERC 
0 include <TBXTypes.h> 

0include <events. h> 
tfendif 

^define REGISTER 

^define MAXNUM 1000 
^define COUNT 10 

^define MODULUS ((long) 0x20000) 

^defineC13849L 
^define A25173L 

long seed =* 7L; 
long random (); 
long buffer [MAXNUM] = {0}; 


main() 

{ REGISTER short i, J; 

REGISTER long temp; 

^include "startup.c" 

printf ("Filling array and sorting *d times\n", COUNT); 
for (i = 0; i< COUNT; ++i) 

{ for (J = 0; J < MAXNUM; ++J) 

{ temp = random (MODULUS); 

if (temp< 0L) 

temp = (-temp); 
buffer[J] = temp; 

} 

printf ("Buffer full, iteration Xd\n", 1); 
quick (0, MAXNUM - 1, buffer); 

} 


^include "done.c" 

} 


quick (lo, hi, base) 
REGISTER short lo, hi; 


am tinned 


BYTE LISTINGS SUPPLEMENT 


JULY-SEPTEMBER, 1987 81 









August 


long base []; 

{ REGISTER Inti, j; 

REGISTER long pivot, temp; 

if (lo < hi) 

{ for (i = lo, j = hi-1, pivot = base [hi]; i < J; ) 

{ while (i< hi &&base [i] <= pivot) . 

++i; 

while (j > lo && base [J ] > = pivot) 

J > 

if(i< J) 

{ temp = base [i]; 
base [i] = base [J]; 
base [J] = temp; 

} 

} 

temp = base [i]; 
base [i] = base [hi]; 
base [hi] = temp; 
quick (lo, i - 1, base); 
quick (i + 1, hi, base); 

} 

} 

long random (size) 

REGISTER long size; 

{ 

seed = seed # A + C; 
return (seed % size); 

} 


SAVAGE.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 2: Savage benchmark * */ 

/# savage.c */ 

^define LSC 
/* 

## savage.c — floating-point speed and accuracy test. C version 
*# derived from BASIC version that appeared in Dr. Dobb's Journal, 

## Sept. 1983, pp. 120-122. 

Modified by Joel West, April 14, 1987 

For accuracy on the Macintosh, we want to use the SANE 80-bit extended type for all compilers. This is: 

Lightspeed C double 
Mac C extended 

Hyper C extended 

Aztec C N/A 

*1 

^define IL00P 2500 
0include <stdio.h> 

tfifdef MACC 

H define EXTENDED extended 
^include <sane.h> 

0else 

tfifdef HYPERC 

^define EXTENDED extended 

H include <TBXTypes.h> 

H include <events.h> 

0else 

^define EXTENDED double 

0endif 

tfendif 
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tfifdef HYPERC 

/'define log(x) ln(x) /* wrong name. Others built in */ 
tfelse 

/'include <math.h> 

/fend if 

main() 

{ inti; 

EXTENDED a; 

/'include "startup.c" 

1) a = 1.0; 

for (i = 1; i<= (IL00P-1); i++) 

a = tan(atan(exp(log(sqrt(a*a))))) +1.0; 

printf("a=*20.l4e\n", a); 

/'include "done.c" 


FLOAT.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 7: Float benchmark #/ 

/'define LSC 
/# float.c*/ 

/# simple benchmark for testing floating-point speed of c libraries does repeated multiplications and divisions in a loop that is 
large enough to make the looping time insignificant */ 

/'include <stdio.h> 

/fifdef MACC 

/'define EXTENDED extended 
ttelse 

tfifdef HYPERC 

/'define EXTENDED extended 

/'include <TBXTypes.h> 

/'include <events. h> 

/'else 

/'define EXTENDED double 
/'end if 
/'end if 

/'define C0NST1 3-141597E0 
/'define C0NST2 1.7839032E4 
/'define COUNT 10000 

main() 

{ EXTENDED a, b, c; 

int i; 

/'include "startup.c" 

a = C0NST1; 
b = C0NST2; 

for (i = 0; i< COUNT; ++i) 

{ c « a # b; 
c = c / a; 
c = a * b; 
c = c / a; 
c * a * b; 
c = c / a; 
c ■ a # b; 
c = c/ a; 
c « a # b; 
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c * c / a; 
c = a # b; 
c = c/ a; 
c = a # b; 
c = c / a; 


#include "done.c" 

} 


DONE.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 10: standard termination header #/ 

/* done.c */ 

/# End timing*/ 

time = TickCount() - time; 
printf("ticks=jtld\n",time); 
printf("Press any key to return to FINDER: "); 
getchar(); 


FiB.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219. 


/# Listing 5: Fib benchmark */ 

^define LSC 
/* Fib.c*/ 

/# Fibonacci benchmark, modified by Joel West, 4/13/87*/ 

^include <stdio.h> 

tfifdef HYPERC 
0include <TBXTypes.h> 

^include <events.h> 
tfendif 

^define REGISTER 

^define NTIMES 10 /* number of times to compute Fibonacci value #/ 
^define NUMBER 24 /* biggest one we can compute with 16 bits */ 


main() /* compute Fibonacci value #/ 

{ REGISTER short i; 

REGISTER unsigned short value; 
uns igned short f ib (); 

#Include "startup.c" 

for (1« 1; i <= NTIMES; i++) 
value = fib(NUMBER ); 

^include "done.c" 

exit(0); 

} 


unsigned short flb(x) /» compute Fibonacci number recursively */ 
REGISTER short x; 

{ if (x > 2) 
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} 


return (fib(x - 1) + fib(x -2)); 
else 

return (1); 


FILEIO.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited,” August 1987, page 219. 


/# Listing 8: Fileio benchmark #/ 

^define LSC 
/* fileio.c */ 

/* file reading and writing benchmark sequentially writes a 65,000-byte file on disk, generates random long numbers, and uses 

these modulo 65,000 to read and write strings of ODDNUM bytes with the file-handling system of the c package; the random-number 
generator is set to a specific seed, so that all compilers should generate the same code 

Fixed by Joel West, April 16, 1987, to use UNIX-standard creat() 
and open() parameters. 

*/ 

^include <stdio.h> 

tfifdef LSC 
^include <unix.h> 
ftelse 

^ifndef MACC /# this is the right way to do it */ 

^include <fcntl.h> 

#endif 

tfendif 

tfifndef MACC 

^define FILEMODE 0666 /# the normal rw-rw-rw */ 

#else 

^define FILEMODE 0x7 /# Mac C only */ 

^define 0_RD0NLY 0 
^define 0_WR0NLY 1 
^define 0_RDWR 2 
0endif 

0ifdef LSC 

0define abort AbOrT / # Lightspeed C has an ' abort' entry point */ 

flendif 

^define ERROR -1 
^define READERR 0 
^define 0KCL0SE 0 

/# For lseek() #/ 

^define BEG 0 
^define CURR 1 
^define END 2 

^define FILESIZE 65000L 
^define COUNT 500 

^defineC13849L 
^define A25173L 
^define ODDNUM 23 

long seed ■ 7L; 

long random (), lseek (); 


main () 

{ inti; 

long J , pos; 
int fd; 

char buffer [ODDNUM+ 1]; 


continued 
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H include "startup.c" 

if ((fd = creat ("test.dat", FILEMODE)) == ERROR) 
abort ("Can't create data file\n"); 
else 

printf ("File opened for sequential writlng\n"); 

for (j =0; j< FILESIZE; ++j) 
if (write(fd, "x", 1) == ERROR) 
abort ("Unexpected EOF in writing data file\n"); 

if (close (fd) ! = 0KCL0SE) 
abort ("Error closing data f ile\n"); 
else 

printf ("Normal termination writing data f ile\n"); 

if ((fd * open ("test.dat", 0_RDWR)) == ERROR) 
abort ("Can't open data file for random reading and writing\n"); 
else 

printf ("File opened for random reading and writing\n"); 

for (1 = 0; i< COUNT;++i) 

{ j = random (FILESIZE); 

if (J < 0L) 

J = (-J); 

if (FILESIZE-j < ODDNUM) 
continue; 

if ((pos = lseek (fd, j, BEG)) *■ -1L) 
abort ("Error reading at random offset\n"); 
if (read (fd, buffer, ODDNUM) == READERR) 
abort ("Error reading at random offset\n"); 
j = random (FILESIZE); 
if (J < 0L) 

J s (-J); 

if (FILESIZE- J < ODDNUM) 
continue; 

if ((pos = lseek (fd, J , BEG)) =* -1L) 
abort ("Error seeking to random offset\n"); 
if (write (fd, buffer, ODDNUM) == READERR) 
abort ("Error writing at random offset\n"); 

} 

if (close (fd) ! = 0KCL0SE) 

abort ("Error closing data file\n"); 

else 

printf ("Normal termination from random reading and writing\n"); 


0include "done.c" 

} 


long random (size) 


long size; 

{ seed = seed * A + C; 

return (seed % size); 

} 

abort(message) 
char *message; 

{ printf(message); 

exit (ERROR); 

} 
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CHAOSBEN.BAS Contributed by Jerry Pournelle. Accompanies "Computing At Chaos Manor: Faster, Bigger, Better," August 1987, page 
243. 


The Benchmark Program 

REM A benchmark program to test machines, compilers, and languages. 
REM ** DECLARATIONS 

DEFINT I - N 
DEFINT E 
DEFDBL A - C 
DEFDBL S 

REM Variable "start$" is a string. 

REM #** CONSTANTS 

ELEMENTS = 50 
SUM = 0 

BELL$ = CHR$(7) 

REM #*# DIMENSIONS 

DIM A(Elements, Elements) 

DIM B(Elements, Elements) 

DIM C(Elements, Elements) 

REM *#* PROGRAM 

CLS ' Clear the screen or it' 11 scroll funny 

Print "This is a program to fill two matrices of "; 
print Elements; 

print " elements, multiply them, and sum the result." 
print 

print "It can be used as a benchmark program to test "; 

print "languages, compilers, or machines." 

print 

print "Written by Jerry Pournelle, May 1987." 
print "Not copyrighted." 

input "Start timer. Enter any character to begin. ";start$ 

GOSUB FillA 
Print "A Filled." 

GOSUB FillB 
Print "B Filled" 

GOSUB FillC ' Needed because some compilers can 1 1 cope. 

Print "C Filled" 

GOSUB DoMultiply 
Print "Multiplied" 

GOSUB SumltUp 
Print "Sum * "jSum 
BEEP (5) 

END 

REM ########**### PROCEDURES ########## 

FillA: 

FOR i * 1 to Elements 
FOR J = 1 to Elements 
A( i#J) ■ i +J 
NEXT 
NEXT 

RETURN » End FillA 
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FillB: 

FOR i = 1 to Elements 

FOR j = 1 to Elements 
B(i,J)-(i + J) / J 
NEXT 
NEXT 

RETURN 'End FillB 

FillC: 

FOR I = 1 = 1 to Elements 
FOR j = 1 to Elements 
C(i,J)«0 
NEXT 
NEXT 

RETURN ' End FillC 

DoMultiply: 

FOR 1 = 1 to Elements 
FOR j = 1 to Elements 
FOR k = 1 to Elements 

C(i,J) *C(i,J) +A(i,k) *B(k,J) 
NEXT 
NEXT 
NEXT 

RETURN ' End DoMultiply 

SumltUp: 

FOR i = 1 to Elements 
FOR j = 1 to Elements 
SUM = SUM + C(i,J) 

NEXT 

NEXT 

RETURN ' End SumltUp 

Print "ESAD!" ' Shouldn' t be able to get here. 

END 
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ALSPRO.TST Contributed by Alex Lane. From "ALS Prolog," BYTE, September 1987. 


"Translations" of Prolog benchmarks first used on Turbo Prolog. 

When running these benchmarks, remember that the read/1 predicate expects to see a period to signal the end of input! 
Note: All errors from the original set of benchmarks have been fixed. 

a.lane (4/17/87) 


% Factorial Benchmark Test 
fact 

write ('Enter number of iterations '), 
read(Iter),nl, 

write('Enter factorial number '), 
read(Num),nl,nl, 
time(Start), 
repeat(Iter,Num), 

time(Finish) ,nl, Overall is Finish - Start, 
write('Time is '),write(Overall),nl. 

factorial(l,l) !. 
factorial(N,Result) 

N1 isN-1, 

factorial(Nl, Temporary), 

Result is N * Temporary. 

repeat(0,R) write(X),nl. 
repeat(N,R) factorial(R,_), 

N1 isN-1, 
repeat(Nl,R). 

time(Time) :-Time is cputime. 


% . 

% List-Reversal Test Program 
lrev 

write('Enter cycle length '), 
read(N), 
time(Start), 
cycle(N), 

time(Finish), Overall is Finish - Start, 
write('Time * '),write(Overall),nl. 


append( [], L, L). 

append( [Z|L1], L2, [Z|L3] ) :-append( LI, L2, L3 ). 


lips(L) :-rev([l, 2 , 3 ,4, 5 ,6,7,8,9, 10,11,12, 13 , 14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36, 
37,38,39,40,41,42,43,44,45,46,47,48,49,50],L). 


llpshort(L) :-rev( [1,2,3,4,5,6,7,8,9,10], L). 


rev( [],[]). 

rev( [H|T], L) :-rev(T,Z), append( Z, [H], L). 


cyele(0). 

oycle(N) :-Nl IsN-1, llps(_), oycle(Nl). 
tlme(Tlme) :-Tlme Is cputime. 


continued 
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* ---- 

% Floating-Point Test Program 

% This floating-point benchmark is significantly different from the one performed on Turbo Prolog. 

* 

% The heart of the Turbo benchmark reads: 

% 

% calc(A,B) 

% C is 1.0, 

% Cl is C* A, 

% C2 is Cl * B, 

% C3 is C2 / A, 

% C is C3 / B, 

% bound(C). 

% 

% which is flawed for two reasons. First, the value of C is reinitialized each time the predicate calc/2 is called, which defeats 
% one of the reasons for performing these operations 5000 times: to see if there is any cumulative error. Second, the Turbo 
% benchmark works only if the result of C3 / B is *exactly# 1.0. If there is any error (i.e., if, as is true with ALS Prolog, 

% C3 / B is 1.00000000000000000001) the thing won't fly at all. 

float 

time(Start), 

cycle(5000, 1.0, 2.71828, 3-14159 ), 
time(Finish), Overall is Finish - Start, 
write('Time is '),write(0verall),nl. 

calc(In,0ut,A,B) 

Cl is In * A, 

C2 is C1#B, 

C3 is C2 / A, 

Out is C3/ B. 

cycle(0,C,A,B) 
write('C is ',C),nl. 

cycle(N,C,A,B) 

calc(C,CF,A,B), 

N1 isN-1, 
cycle(Nl,CF,A,B). 

time(Time) :-Time is cputime. 

% - 

% Math Functions Test Program 
goal 

write('Doing square root... '),nl, 
time(Tl), 

eyelesqrt(1000,_,T1), 
write (' Doing logs..'), nl, 
time(T2), 

cycleln(l000,_,T2), 
write(' Doing exp..'), nl, 
time(T3), 

eyeleexp(1000,_,T3), 
write( 'Doing atan.. '),nl, 
time(T4), 

cycleatan(1000,_,T4), 
write( 'Doing sin...') ,nl, 
time(T5), 

cyclesin(1000,_,T5). 

cyclesqrt(0,R,Tl) time(T6), Stime is T6 - Tl, 

write('SQRT : '),write(Stime),nl,!. 


cyclesqrt(N, R, T) 

N > 0, Nl is N - 1, R is sqrt(100.0), cyclesqrt(Nl,R,T). 

cycleln(0,R,T2) :-time(T7), Ltime isT7-T2, 

write('LN: '),write(Ltime),nl. 

cycleln(N, R,T) 

N>0, Nl isN-1, R is log (100.0), cycleln(Nl,R,T). 
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cycleexp(0,R,T3) :-time(T8), Etime isT8-T3, 

write('EXP : *),write(Etime),nl. 


cycleexp(N, R,T) 

N> 0, N1 is N - 1, R is exp(10.0), cycleexp(Nl,R,T). 

cycleatan(0,R,T4) time(T9), Atime is T9 - T4, 

write(' ATAN : *),write(Atime),nl. 


cycleatan(N, R,T) 

N > 0, N1 is N - 1, R is atan(lO.O), cycleatan(Nl,R,T). 

cyclesin(0,R,T5) time(TlO), Stime is T10 - T5, 

writeOSIN: '),write(Stime),nl. 


cyclesin(N, R,T) 

N > 0, N1 is N - 1, R is sin(lO.O), cyclesin(Nl,R,T). 
time(Time) :-Time is cputime. 


% Disk Read Program 
dread 

see('a:tempo.dat'), 

time(Start), 

get_text(512), 

time(Finish), Overall is Finish - Start, 
seen, see(user), 

write('Time= 1 ),write(Overall),nl, 
write('DONE*),nl. 

get_text(0). 
get_text(N) 

read(Str), 

N1 isN-1, 
get_text(Nl). 


% - 

% Disk Write Benchmark 
dwrite 

tell('a:tempo.dat’), 
time(Start), 
send_text(512), 

time(Finish), Overall is Finish - Start, 
told, tell(user), 

write('Time = '),write(Overall),nl, 
write('DONE'),nl. 

sendLtext(O). 
send_text(N) 

write('x2345678123456781234567812345670123456781234567812345678123456701234 
56781234567812345678123456701234567812345678123456781234567.'), 
nl, N1 isN-1, 
sendLtext(Nl). 

time(Time) :-Time is cputime. 

*. 

% Tower of Hanoi Test Program 
hanoi 

write (' Enter tower height '), 
read(High), 
time(Start), 
hanoi(High), 

time(Finish), Overall is Finish - Start, 
write('Time : '),write(Overall),nl. 

hanoi(N) :-move(N, left, center, right). 
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move(0 # _, _) !. 

move(N, A, B, C) 

MisN-1, 
move(M, A, C, B), 
move2(bottom. A, B), 
move(M, C, B, A). 
move2(bottom, A, B) 

write(’Move the disk on ’), 

write(A), 

write(’ to '), 

write(B), 

nl. 

time(Time) Time is cputime. 

% ---- 

% Sieve Test Program 

eratosthenes 
time(Start), 
cycle(10), 

time(Finish), Overall is Finish - Start, 
write('Time is '),write(Overall),nl. 

primes( Limit, Ps ) 

integers( 2, Limit, Is ), 
sift( Is, Ps ). 

integers( Low, High, [Low|Rest] ) 

Low =< High, !, M is Low + 1, 
integers(M, High, Rest). 
integers (_,_,[] ). 

sift( [], []). 
sift( [Ills], [l|Ps]) 

remove(I,Is,New), 
sift( New, Ps ). 

remove(_, [],[]). 
remove(P, [l|Is], [l|Nis]) 

I mod P s \ a o, I, 
remove(P, Is, Nis). 
remove(P,[l|ls],Nis) 

I mod P = := 0, 
remove(P, Is, Nis). 

cycle(O). 
cycle(N) 

Nl isN-1, 
primes(100,_), 
cycle(Nl). 

time(Time) :-Time is cputime. 

% . 

% This program is called with the query "?-boresea(X)." 

% X is the number of loop iterations executed. It should be big enough to give significant results. 
% suggested value for X: 100 for interpreted code 
% 1000 for compiled code 

% average values for C-prolog interpreter: 

% X=1000, Tloop=27.1 T.compel.0 Tnet=26.1 Klips=7.7 

boresea(X) 

:-Tl is cputime, 

do_max_KLips(X), % calls the loop to execute the 

T2 is cputime, % sequence of 200 predicates 

compens_loop(X), % compensation loop 

T3 is cputime, 

print_times(Tl,T2,T3#X,200). % compute and print results 

compen8_loop(0). % compensation loop 

compens_loop(X) Y is X - 1, compens_loop(Y). 
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print_times(Tl,T2,T3,X,I) 


X prints the results 


TT1 is T2 - Tl, 
TT2 is T3 - T2, 
TT is TT1 - TT2, 


write('T overall loop: 
write(*T compens loop: 


f ),vrite(TTl), nl, 
'),write(TT2), nl, 
*),write(TT),nl, 
*), 


write( ’Tnet: 
write('KLips: 
Li is I *X, 


Lips is Li / TT, 

KLips is Lips / 1000, 
write(KLips),nl,nl. 


do_max_KLips(0). 


% loop calling the actual benchmark 


do_max_KLips(X) :- lipsl, Y is X - 1, do_max_KLips(Y). 

% predicates to test call 

lipsl :- lips2. 

Iips2 :- lips3. 

Iips3 lips4. 

Iips4 :- lips5. 

Iips5 lips6. 

Iips6 :- lips7. 

Iips7 :- lips8. 

Iips8 :- lips9. 

Iips9 lipslO. 
lipslO lipsll. 
lipsll lipsl2. 
lips12 lipsl3. 

Iipsl3 lipsl4. 

Iipsl4 lipsl5. 

Iipsl5 lipsl6. 

Iipsl6 lipsl7. 

Iipsl7 :-lipsl8. 

Iipsl8 :-lipsl9. 

Iipsl9 lips20. 

Iips20 lips21. 

Iips21 :- lips22. 

Iips22 lips23. 

Iips23 lips24. 

Iips24 :-lips25. 

Iips25 lips26. 

Iips26 lips27. 

Iips27 lips28. 

Iips28 :- lips29. 

Iips29 :-lips30. 

Iips30 :- lips31. 

Iips31 :-lips32. 

Iips32 :-lips33. 

Iips33 lips34. 

Iips34 :-lips35. 

Iips35 :-lips36. 

Iips36 :- lips37. 

Iips37 :-lips38. 

Iips38 :- lips39. 

Iips39 :- lips40. 

Iips40 :- lips4l. 

Iips4l :-lips42. 

Iips42 :-lips43. 

Iips43 lips44. 

Iips44 :- lips45. 

Iips45 lips46. 

Iips46 :- lips47. 

Iips47 :- lips48. 

Iips48 :- lips49. 

Iips49 lipslO. 

Iips50 :- lipsll. 

Iips51 :-lips52. 

Iips52 :-lips53. 

Iips53 :-lips54. 

Iips54 :- lips55. 

Iips55 :-lips56. 

Iips56 :-lips57. 

Iips57 :-lips58. 
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lips58 :-lips59. 
Iips59 lips60. 
Iips60 lips6l. 
Iips6l lips62. 
Iips62 lips63. 
Iips63 lips64. 
Iips64 :-lips65. 
Iips65 lips66. 
Iips66 lips67. 
Iips67 :-lips68. 
Iips68 :-lips69. 
Iips69 :-lips70. 
Iips70 lips71. 
Iips71 lips72. 
Iips72 :-lips73. 
Iips73 lips74. 
Iips74 :-lips75. 
Iips75 :-lips76. 
Iips76 :-lips77. 
Iips77 lips78. 
Iips78 lips79. 
Iips79 lips80. 
Iips80 lips81. 
Iips81 lips82. 
Iips82 :-lips83. 
Iips83 :-lips84. 
Iips84 :-lips85. 
Iips85 lips86. 
Iips86 lips87. 
Iips87 lips88. 
Iips88 lips89. 
Iips89 lips90. 
Iips90 lips91. 
Iips91 :-lips92. 
Iips92 :-lips93. 
Iips93 :-lips94. 
Iips94 :-lips95. 
Iips95 lips96. 
Iips96 :-lips97. 
Iips97 :-llps98. 
Iips98 :-lips99. 
Iips99 lipslOO. 
lipslOO lipslOl 
lipslOl lipsl02 
lips 102 lipsl03 
lipsl03 lips104 

lips104 lipsl05 
lipsl05 :-lipsl06 
lipsl06 lipsl07 
lipsl07 lipsl08 
lipsl08 lipsl09 
lipsl09 lipsllO 
lipsllO lipslll 
lipslll lipsll2 
lipsll2 lipsll3 
lipsll3 lipsll4, 
lipsll4 lipslll 
lipsll5 lipsll6. 
Iipsll6 lipsll7. 
Iipsll7 lipsll8. 
Iipsll8 lipsll9. 
Iipsll9 lipsl20. 
Iipsl20 lipsl21. 
lips121 lipsl22. 

lips 122 lipsl23« 

lips123 lips124. 

Iipsl24 :-lipsl25. 
Iipsl25 lipsl26. 
lips126 lipsl27. 
Iipsl27 lipsl28. 
Iipsl28 lipsl29. 
lips129 lipsl30. 
Iipsl30 :-lipsl31. 
Iipsl31 :-lipsl32. 
lips 132 :-lipsl33. 
Iipsl33 :-lipsl34. 
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lipsl34 :-lipsl35. 

Iipsl35 lipsl 36 . 

Iipsl36 :-lipsl37. 

Iipsl37 :-lipsl 38 . 

Iipsl38 :-lipsl39. 

Iipsl39 s- lipsl40. 

Iipsl40 lipsl4l. 

Iipsl4l lipsl42. 

Iipsl42 :-lipsl43. 

Iipsl43 lipsl44. 

Iipsl44 lipsl45. 

Iipsl45 lipsl46. 

Iipsl46 lipsl47. 

Iipsl47 :-lipsl48. 

Iipsl48 lipsl49. 

Iipsl49 lipsl50. 

Iipsl50 lipsl^l. 

Iipsl 51 :-lipsl 52 . 

Iipsl52 lipsl53* 
lipsl53 :-lipsl54. 

Iipsl54 :-lipsl55. 

Iipsl55 lipsl 56 . 

Iipsl56 :-lipsl57. 

Iipsl57 :-llpsl58. 

Iipsl58 ;-llpsl59. 

Iipsl 59 lipsl60. 

Iipsl60 lipsl 6 l. 

Iipsl 6 l lipsl62. 
lips 162 :-lipsl63. 

Ilpsl63 lipsl64. 

Iipsl64 :-lipsl65. 

Iipsl65 2 - lipsl 66 . 
lips166 2 - lipsl67. 

Iipsl67 :-lipsl 68 . 

Iipsl 68 lipsl69. 
lips169 2 - lipsl70. 

Iipsl70 2-lipsl71. 

Iipsl71 2 - lipsl72. 

Iipsl72 :-lipsl73. 

Iipsl73 2 - lipsl74. 
lips 174 :-lipsl75. 

Iipsl75 2 - lipsl76. 

Iipsl76 lipsl77. 

Iipsl77 2 - lipsl78. 

Iipsl78 2 - lipsl79. 
lips179 2 - lipsl80. 

Iipsl80 2 -lipsl 81 . 

Iipsl81 lipsl82. 

Iipsl82 2 - lipsl 83 . 

Iipsl83 2 - lipsl84. 

Iipsl84 lipsl85. 

Iipsl85 lipsl 86 . 

Iipsl 86 2 - lipsl87. 

Iipsl87 2 - lipsl 88 . 

Iipsl 88 lipsl89. 
lips189 2 - lipsl90. 
lips190 2 - lipsl91. 

Iipsl91 lipsl92. 
lips192 lipsl93* 
lipsl93 :-lipsl94. 
lips194 lipsl95. 

Iipsl95 2 - lipsl96. 
lips 196 :-lipsl97. 

Iipsl97 t- lipsl98^ 
lips198 2 - lipsl99. 
lips199 lips 200 . 

Iips 200 . 

% . 

% Choice Point Benchmark. 

% The predicates are called: 

% o ”choice_point(N)" - creation of choice points 

% N is the number of loop iterations executed 


continued 
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% predicate to test creation of choice points without 
% backtracking 


choice_point(N) T1 is cputime, 
cre_CP(N), T2 is cputime, 
compens_loop(N), T3 is cputime, 
print_times(Tl,T2,T3,N,20). 

% compensation loop, used to measure the time spent in 
% the loop 

compens_loop(0). 

compens_loop(X) : - Y is X - 1, compens_loop(Y). 

% loop to test choice point creation 
cre_CP(0). 

cre_CP(N) :-M is N-l, ccpl(0,0,0), cre_CP(M). 
cre_CP0ar(0). 

cre_CPOar(N) :-M is N-l, ccpl, cre_CPOar(M). 


print_times(Tl,T2,T3,X,I) 

TT1 is T2-T1, 

TT2 is T3 - T2, 

TT is TT1-TT2, 
write(*T overall loop: 
write(*T compens loop: 
write( 'T net: 
write('KLips: 

Li is I * X, 

Lips is Li / TT, 

KLips is Lips / 1000, 
write(KLips),nl,nl. 


% prints the results 


, ),write(TTl), nl, 
'),write(TT2), nl, 
'),write(TT),nl, 


% ccpl creates 20 choice points 

% ccpl is the beginning of a set of predicates composed of 2 clauses each. Every invocation of ndO will create 
% a sequence of 20 choice points. The body of the clauses are limited to one goal, thus avoiding a creation of environment 
% when the clause is activated. ndO, and its successors, have three arguments to comply with our average static analysis 
% results made on more than 30 real Prolog programs. 

% ccpXX exists with 3 arguments, and 0 args. 


ccpl(X,Y,Z):-ccp2(X,Y,Z). 
ccpl(X,Y,Z). 

ccp2(X,Y,Z):-ccp3(X,Y,Z). 
ccp2(X,Y,Z). 

ccp3(X,Y,Z):-ccp4(X,Y,Z). 
ccp3(X,Y,Z). 

ccp4(X,Y,Z):-ccp5(X,Y,Z). 
ccp4(X,Y,Z). 

ccp5(X,Y,Z):-ccp6(X,Y,Z). 
ccp5(X,Y,Z). 

ccp6(X,Y,Z):-ccp7(X,Y,Z). 
ccp6(X,Y,Z). 

ccp7(X,Y,Z):-ccp8(X,Y,Z). 
ccp7(X,Y,Z). 

ccp8(X,Y,Z):-ccp9(X,Y,Z). 
ccp8(X,Y,Z). 

ccp9(X,Y,Z):-ccpl0(X,Y,Z). 
ccp9(X,Y,Z). 

ccpl0(X,Y,Z):-ccpll(X,Y,Z). 
ccpl0(X,Y,Z). 

ccpll(X,Y,Z):-ccpl2(X,Y,Z). 
ccpll(X,Y,Z). 

ccpl2(X,Y,Z):-ccpl3(X,Y,Z). 
ccpl2(X,Y,Z). 

ccpl3(X,Y,Z):-ccpl4(X,Y,Z). 
ccpl3(X,Y,Z). 

ccpl4(X,Y,Z):-ccpl5(X,Y,Z). 
ccpl4(X,Y,Z). 

ccpl5(X,Y,Z):-ccpl6(X,Y,Z). 
ccpl5(X,Y,Z). 

ccpl6(X,Y,Z):-ccpl7(X,Y,Z). 
ccpl6(X,Y,Z). 

ccpl7(X,Y,Z):-ccpl8(X,Y,Z). 
ccp!7(X,Y,Z). 
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ccpl8(X,Y,Z):-ccpl9(X,Y,Z). 
ccpl8(X,Y,Z). 

ccpl9(X,Y,Z):-ccp20(X,Y,Z). 
ccpl9(X,Y,Z). 
ccp20(X,Y,Z). 
ccp20(X,Y,Z). 


KAREX3.BAS Accompanies the article "Karmarkar's Algorithm” by Andrew M. Rockett and John C. Stevenson, BYTE, September 1987. 


100 '. 

101 * 

102 * KAREX3. BAS is a Microsoft BASIC Release 5 program 

103 * that solves EXAMPLE 3 of the article 

104 » 

105 ' KARMARKAR * S ALGORITHM 

106 • 

107 ’ by Andrew M. Rockett and John C. Stevenson 

108 * 

109 ' This program was written by Andrew M. Rockett 

110 1 

111 '- 

200 ' 

202 ' N is the number of unknowns and K is the number of equations 
204 ' 

206 N = 8 : K = 4 
208 ' 

210 K1 = K + 1 : K2 = 2#K1 

212 DIMAO(N), X0LD(N), XNEW(N), CC(N), CP(N), A(K,N), B(K1,N), B1(K1,K2), B2(N,K1), B3(N,N) 
214 FOR C = 1 TO N : A0(C) = 1/N : XNEW(C) = A0(C) : 

NEXT C 

216 ' 

218 1 T is the tolerance 
220 ' 

222 T= .001 
224 ' 

226 ' ALPHA is usually set equal to 1/4 ... 

228 ' 

230 ALPHA = .25 
232 ' 

234 ITERATION = 0 
236 1 

238 ' Data for constraint matrix A 
240 * 

242 DATA 1, 0, -1, 0, 0, 0, 3, -3 
244 DATA 1, 0, 0, 1, 0, 0, 0, -2 
246 DATA 0, 1, 0, 0, 1, 0, 3, -5 
248 DATA 0, 1, 0, 0, 0, -1, 4, -4 
250 • 

252 FOR R = 1 TO K : FOR C * 1 TO N : READ A(R,C) : 

NEXT C : NEXT R 

254 ' 

256 ' Data for objective function CC 
258 ' 

260 DATA 0, 0, 0, 0, 0, 0, 1, 0 
262 ' 

264 FOR C - 1 TO N : READ CC(C) : NEXT C 
266 ' 

268 V = 0 : FOR C=1 TO N : V = V + CC(C)#A0(C) : 

NEXT C : VNEW * V 

270 ' 

272 ' Main iteration process is the same as in KAREX1.BAS ... 

274 ' 

300 WHILE VNEW/V>T 

301 PRINT USING "###"j ITERATION;: 

FOR C*1 TO N:PRINT USING ”###.####" ;XINEW(C); : 

NEXT C : PRINT USING #######"; VNEW/V 

302 ITERATION - ITERATION + 1 

303 FOR C ■ 1 TO N : X0LD(C) = XNEW(C) : NEXT C 


continued 
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304 FOR R=1 TO K:FOR C=1 TO N:B(R,C)=A(R,C)*XOLD(C): 

NEXT C: NEXT R 

305 FOR C=1 TO N:B(K1,C)=1:NEXT C 

306 FOR R=1 TO K1 : FOR C=1 TO K2 : B1(R,C)=0 : 

NEXT C : NEXT R 

307 FOR R-l TON : F0RC=1T0 K1 : B2(R,C)=0 : 

NEXT C : NEXT R 

308 FOR R=1 TO N : F0RC=1T0N : B3(R,C)=0 : 

NEXT C : NEXT R 

309 FOR C=1 TO N : CP(C) = 0 : NEXT C 

310 FOR R=1 TO K1: FOR C=1 TO K1: 

FOR 1=1 TO N:Bl(R,C)=Bl(R,C)+B(R,I)#B(C,I): 

NEXT I: 

NEXT C: NEXT R 

311 FOR I = 1 TO K1 : B1(I,I+K1)=1 : NEXT I 

312 FOR R = 1 TO K1 

313 IF Bl(R,R) <>0 THEN 318 

314 I = R + 1 

315 IF I > K1 THEN PRINT "Error! BBT is SINGULAR!" : 

GOTO 405 

316 IFB1(I,R) = 0 THEN I = 1+1 : GOTO 315 

317 FOR C = 1 TO K2 : SWAP B1(R,C) ,Bl(I,C) : NEXT C 

318 FOR I = R+l TO K1:Z = B1(I,R)/Bl(R,R): 

FOR C=1 TO K2:B1(I,C)=B1(I,C)-Z#B1(R,C):NEXTC: 

NEXT I 

319 NEXT R 

320 FOR R=K1 TO 2 STEP -1:FOR I = R-l TO 1 STEP -1:Z = Bl(I,R) /Bl(R,R) 

FOR C=R TO K2:B1(I,C)=B1(I,C)-Z#B1(R,C):NEXT C: 

NEXT I:NEXTR 

321 FOR R=1 TO K1:Z = B1(R,R): 

FOR C=1 TO K2:B1(R,C)=B1(R,C) /Z:NEXT C: 

NEXT R 

322 FOR R=1 TO N: FOR C=1 TO K1: 

FOR J=1 TO K1:B2(R,C)=B2(R,C)+B(J,R)#B1(J,C+K1): 

NEXT J: 

NEXT C: NEXT R 

323 FOR R=1 TO N: FOR C=1 TO N: 

FOR J=1T0 K1:B3(R,C)=B3(R,C)+B2(R,J)»B(J,C): 

NEXT J: 

NEXT C: NEXT R 

324 FOR R = 1 TO N : B3(R,R) = B3(R,R) - 1 : NEXT R 

325 FOR R=1 TO N: FOR C=1 TO N:B3(R,C)=-1^B3(R,C): 

NEXT C: NEXT R 

326 FOR R=1 TO N:FOR C=1 TO N:B3(R,C)=B3(R,C)^XOLD(C): 

NEXT C: NEXT R 

327 FOR R=1 TO N:FOR C=1 TO N:CP(R)=CP(R)+B3(R,C)^CC(C): 

NEXT C: NEXT R. 

328 AA=0:F0R C=1 TO N : AA = AA + CP(C)#CP(C) : NEXT C 

329 AA = SQR(AA) : FOR C=1 TO N : CP(C) = CP(C) /AA : 

NEXT C 

330 AA = SQR(N#(N-1)) / ALPHA 

331 FOR CHITON : XNEW(C) « (AO(C) - CP(C) /AA)*XOLD(C) : 

NEXT C 

332 AA=0:FORC=1TON : AA = AA + XNEW(C) : NEXT C 

333 FOR C*1 TON : XNEW(C) =XNEW(C)/AA : NEXT C 

334 VNEW=0: FOR C«1 TO N: VNEW=VNEW+CC(C)*XNEW(C) :NEXT C 

335 • 

336 ' FAILURE DETECTION routine based on equation (6) ... 

337* 

338 * You may wish to put this routine into KAREX1 and 

KAREX2 to 

339 * observe the values appearing in (6) during the solutions 

340 * of EXAMPLES land 2. 

341 ' 

342 AA = 0 

343 FOR C = 1 TO N 

344 IF XNEW(C) > 0 THEN A A = AA + L0G(XNEW(C)) 

345 NEXT C 

346 PRINT , LOG(VNEW/V), LOG(N) + AA/N - ITERATION/ (8#N) 

347 * 

348 IFLOG(VNEW/V) > LOG(N) + AA/N - ITERATION/(8#N) 

THEN 400 

349 ' 

350 WEND 

351 ' 


98 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 







September 


400 PRINT : PRINT "Failure condition has occurred." : 

PRINT 

401 PRINT USING "###"; ITERATION; : 

FOR C=1 TO N:PRINT USING ”###.####";XNEV(C); : 
NEXT C : PRINT USING "####. #######"; VNEW/V 

402 • 

403 PRINT:FOR C=1 TO N-2:PRINT XNEW(C)/XNEW(N), : 

NEXT C: PRINT 

404 ' 

405 END 


BAM.PAS From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


program bam; 

{ for further information 

Rod Taber 
General Dynamics 

Electronics Division Mail Zone 7202-K 
Box 85310 

San Diego, CA 92138 

Mail without the Mail Zone takes 3 months.} 

{$R+,V+,K+,C-,U-} 


const 


maxrows 

* 12; 

maxcolumns 

= 12; 

maxentries 

* 144 

maxpatterns 

= 4; 

screenrows 

= 24; 

screencolumns 

= 80; 


type 
threeD * 
twoD * 
oneD = 
square = 
Textin = 
var 


array[0..maxpatterns,l..1,1..maxentries] of integer; 

array[1..maxentries] of integer; 

array[l..maxentries] of integer; 

array[1..maxentries,l..maxentries] of integer; 

string[15]; 


Ham:array[1..maxpatterns] of integer; 

Bipolar_A,BipolarJB,Pattern_A,Pattern_B 

OriginalTestPattern,OutPatt 

TestPattern, /UCheck,B_Check 

Rows_A,Rows_B,Columns_A,Columns_B 

MinHam,Num_Patterns,Length_A,Length^B 

Memory 

topline,bottomline,margin,leftone,rightone 
le fttwo,le ftthree,righttwo,rightthree,le ftfour 
energy 

threshold,pattern_number,TL,LL,AR,AC,PAC,PAR 

test_type,Matrix^Used 

Synchmode,input,input_a,input.b 

inputfile,outfle 

filename,filename2 


:threeD; 
:oneD; 

:oneD; 

:integer; 

:integer; 

:square; 
.•integer; 

:integer; 
:real; 

:integer; 

:char; 

:boolean; 
:text; 

:string[10]; 


{$1 xface. inc} 

function max (x,y: integer): integer; J 

begin 

if x > y then max : = x 
else max :■ y; 

end; 

{ ##*####*####################*######################################################### j 

functionmin(x,y: integer): integer; 


continued 
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begin 

if x< y then min := x 
else min : = y; 

end; 

{ a#################*###########*####################################################### 

{ a#**##*****##*#*##*###*#***##*##**##*#**###**##****#*********##*#***#*#*****#*##**##*# 

procedure zero_test; 
var 

index:integer; 
begin 

for index : = 1 to maxentries do 

TestPattern[index] := 0; { zero out Test matrix } 

end; 

{ a##*################################################*###########*##################### 

{ a############*#####################*##########**#*###################*##*############# 

Procedure Reader (var charValue,errorCode:integer); 

{Read the screen at cursor position} 
type 

RegPack = record 

AL,AH,BL,BH,CL,CH,DL,DH : Byte; 

BP,SI,DI,DS,ES,Flags : Integer; 

end; 
var 

Regs : RegPack; 

begin 

with Regs do 

begin 

Errorcode:=0; {assume no error} 

AH: =$8; BH:=$0; {code 8-screen read, page 0} 

Intr($10,Regs); {get character in AL via int 10h} 
charValue: = AL; {used to be AL - 48 !!!!!} 
end; 

end; {Reader} 

{ a#################*#########*##***###########################################**####### 

{ a###############################*################**#*####*########**################*# 

procedure Read_Rov_and_Column_Values; 

var 

x:integer; 
begin 
repeat 

textbackground(lightcyan); 

clrscr; { clears out any predefined user background } 

textmode(C80); 
textbackground(lightcyan); 
textcolor(red); 

GoToXY(8,4); 

write('B IDIRECTIONAL ASSOCIATIVE MEMORY'); 

GoToXY(8,7); Textcolor(blue); 

write(' Enter the number of patterns to store. < 1..', maxpatterns,' > '); 

readln(num_patterns); 

GoToXY(8,8); 

write (' Enter the number of rows in pattern A: < 1..', maxrows,' > '); 

readln(rows_a); 

GoToXY(8,9); 

write( 'Enter the number of columns in pattern A: < 1..' ,maxcolumns,' > '); 
readln(columns_a); 

GoToXY(8,10); 

write(' Enter the number of rows in pattern B: < 1..', maxrows,' > '); 

readln(rows_b); 

GoToXY(8,ll); 

write('Enter the number of columns in pattern B: < 1..' ,maxcolumns,' > '); 
readln(columns_b); 

GoToXY(8,12); 

writeln( 'Enter the threshold of neuron activation:'); 

GoToXY(10,13); 

write(' Value must be in range: - ', maxentriesmaxentries,' '); 
readln(threshold); 

Length^A : = Rows_A * Columns_A; 

LengtluB :■ RowsJ3 * columns_B; 
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TextColor(Red + Blink); { blinks if inputs are unacceptable } 

if Length_A <= maxentries then input_a : = True 
else 
begin 

input_a := False; 

GoToXY(l3,17); 

writeln(' Values for matrix A are out of bounds.'); 
repeat until keypressed; 
end; 

if Length_B <= maxentries then input_b := True 
else 
begin 

input_b : = False; 

GoToXY(l3,17); 

writeln( ’ Values for matrix B are out of bounds.'); 
repeat until keypressed; 
end; 

if num_patterns < min(length_a,length_b) then input : = True 
else 
begin 

input : = False; 

GoToXY(13,17); 

writelnC Number of patterns must be less than ' ,min(length_a,length_b)); 
repeat until keypressed; 
end; 

TextColor(Blue); 

until (input_a and input_b and input); { all inputs are within range } 
end; 

{ ********####****X##**####****X##**###*#***********####***###*******************####*** } 

{ ************************************************************************************** } 
procedure UseCurrentScreenSetup; 

begin 


Synchmode 

:= Tr 

topline 

5; 

bottomline 

s 15; 

margin 

= 3; 

leftone 

* 4; 

rightone 

= 18 

lefttwo 

= 22 

righttwo 

= 36 

leftthree 

= 40 

rightthree 

= 54 

leftfour 

i; 

= 58 


{ ************************************************************************************** } 

{ ************************************************************************************** } 
procedure SetMemoryToZero; 

{$R+,V+,K+,C-,U-} 


var 

index,row,column,size:integer; 
begin 

size := max(length_a,length_b); 
for row :■ 1 to size do 
for column : * 1 to size do 
memory [row, column] :=0; 

end; 

{ ************************************************************************************** } 

{ ************************************************************************************** ) 

Procedure SaveScreen(Matrix_Used:char;row_in,column.in:integer); 

var 

position,charValue,ErrorCode :integer; 

begin 

position ;«1; 

for AR : = 1 to row__in do 
begin 

for AC : ■ 1 to columa_in do 
begin 

PAC:«LL+AC-1; 


continued 
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PAR:=TL+AR-1; 

GoToXY(PAC,PAR); 

Readcr(charValue,ErrorCode); Delay(2); 
if ErrorCode <> 0 then write('error'); 

case Matrix-Used of 
'A': begin 

if charValue = 177 then 
Pattern_A[Pattern_Number,l,position] := 1 
else 

Pattern. A [Pattern__Number,l,position] := 0; 
end; 

' B': begin 

if charValue = 177 then 
PatterruB[Pattern__Number,l,position] := 1 
else 

PatternJB[Pattera_Number,l,position] := 0; 
end; 

•T': begin 

if charValue = 177 then 
TestPattem[position] :*1 
else 

TestPattem[position] :=0; 
end; 

end; { end case } 

position :* position + 1; 
end; 

end; 

{ the following text erases the instructions yet leaves the Test Pattern } 

if Matrix_Used = 'T' then 

begin 

TextBackground(lightcyan); 

GoToXY(l,BottomLine + 4); { Beginning of instructions on screen } 
writelnO '); 

writeln(' '); 

writeln(' '); 

writeln(' '); 

end; 

end; 

{ tttf******tt*****Otf**M*tt*tt*tt****«**ff*KXtfft***«*****fftttttt*tfft******tttt**tf***ft«tf ************* 

{ ************************************************************************************** 

Procedure DataFromKeyboard (Matrix.Used:char; rows,columns: integer); 

{PatternNumber must be defined prior to call} 

var 

char3 :char; 

intval : integer; 

charValue : integer; 

label 

loopl,InitLoop; 


begin 

TextBackground(lightgray); 

GoToXY(l,l); 

{ only print heading for the first time this screen appears i.e., Matrix_a } 
if Matrix_Used <> 'B' then 
case PatterruNumber of 
0: begin 

write (' Enter the Test Pattern'); 
end; 

1..MaxPatterns: 
begin 

TextColor(blue); 

write(' Enter Pattern Number ' ,pattern_iJumber:2 ); 
end; 

end; {case} 

TextColor(blue); 

TextBackground(lightcyan); 
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case Matrix^Used of 

'A' : begin { Matrix A input } 

GoToXY(LL,TL-2); 
write('MATRIX A’); 
end; 

*8* : begin { Matrix B input } 

GoToXY(le fttwo, TL - 2); 
write(•MATRIXB')i 
end; 

'T' : begin { TestPattem input} 

GoToXY(LL,TL - 2); 
write('TEST PATTERN'); 
end; 

end; { end case } 

TextColor(Magenta); 

TextBackground(lightgray); 

for AR: = 1 to Rows do 
begin 

for AC: = 1 to Columns do 
begin 

PAC: =LL+AC-1; {column to place cursor} 

PAR: =TL+AR-1; {row to place cursor} 

GoToXY(PAC,PAR); 
write(chr(249)); 

GoToXY (PAC, PAR); { cursor stays in position } 

end; 
end; 

{A zero matrix is now on the screen for Pattern ' PatternNumber'} 

TextColor(blue); { INSTRUCTIONS} 

TextBackground(lightcyan); 

GoToXY(l,BottomLine + 4); { Next free line on screen } 

writeln( 1 Position cursor using arrow keys.'); 

writeln( * Press period "." to change pattern.'); 

writeln(' Press space bar to remove changes. *); 

write(* Press RETURN to store Matrix after entering complete pattern 1 ); 

Textbackground(lightgray); 

InitLoop: GoToXY(LL,TL); { cursor to first element of input pattern} 
AC:=LL; {initialize row and column counters} 

AR:=TL; 

loopl:read(kbd,char3); 

intval:=ord(char3); 
if intval = 27 then 
begin 

read(kbd,char3); 
intval:«ord(char3); 
end; 


case intval of { beeps on attempt to move off pattern display } 

80: begin 

if AR + 1 >- Rows + TL then 
begin sound(800); delay(60); nosound; end 
else AR :■ AR+1; { down arrow} 
end; 

72: begin 

if AR - 1 < TL then 

begin sound(800); delay(60); nosound; end 
else AR :« AR-1; {up arrow} 
end; 

75: begin 

if AC-1< LL then 

begin sound(800); delay(60); nosound; end 
else AC AC-1; {left arrow} 
end; 

77: begin 

if AC + 1 >= Columns + LL then 
begin sound(800); delay(60); nosound; end 
else AC : = AC+1; {right arrow} 
end; 


continued 
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46: begin {digits} 

write(chr(177)); 
end; 

32: begin 

textcolor(magenta); 
write(chr(249)); 
textcolor(blue); 
end; 

13: begin 

SaveScreen(Matrix_Used,Rows,Columns); { works for Matrix A, B or Test } 
end; {of case 13} 

end; {case statement} 

GoToXY(AC, AR); {goto new cursor position} 
if intval <> 13 then goto loopl; 

TextBackground(lightcyan); 
end; {DataFromKeyboard} 

{ ************************************************************************************** } 

{ ************************************************************************************** } 

procedure EraseOldMatrices; 

begin 

TextBackground(lightcyan); 

{ clear old Matrix A } 

LL := leftone; 

for AR:= 1 to Rows_A do 

begin 

for AC: = 1 to Columns_A do 
begin 

PAC:=LL+AC-1; {column to place cursor} 

PAR: =TL+AR-1; {row to place cursor} 

GoToXY(PAC,PAR); 
write(' '); 
end; 
end; 

{ clear old Matrix B } 

LL := left two; 

for AR: = 1 to Rows_B do 

begin 

for AC: ■ 1 to Columns_B do 
begin 

PAC:=LL+AC-1; {column to place cursor} 

PAR: =TL+AR-1; {row to place cursor} 

GoToXY(PAC,PAR); 
write(' '); 
end; 
end; 

end; 

{ ************************************************************************************** } 

{ ************************************************************************************** } 

Procedure InputTestPattem; 

var 

n:integer; 
begin 

Pattern_Number :* 0; 

for n : = 1 to maxentries do 
begin 

/L.Check[n] :=0; 

B_Check[n] :»0; 
end; 

TextColor(Red); 
repeat 

GoToXY(l,Bottomline + 2); 


writelnO ’) 
writeln(* ’) 
writeln(' ’) 
writeln(' *) 
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GoToXY(l,Bottomline + 2); 

write( • Is test pattern of type A or B ? (A/B) *); 

readln(test_type); 
until test_type in [ 'a', 'A', »b’,'B* ]; 

GoToXY( 1,Bottomline + 2); { erases 1 Is test pattern of' query } 

writeln ( 1 »). 

{ eliminate lowercase input and relace with uppercase equivalent} 
iftest_type* 'a' then test_type := 'A r ; 
if test_type * • b 1 then test_type 'B f ; 

if test_type= • A * then 
begin 
clrscr; 

TL: stopline; LL:«leftone; 

DataFromKeyboard(•T',rows_a,columns_a); 
end 
else 

begin { if test_type = B } 
clrscr; 

TL :* topline; LL :* leftone; 

DataFromKeyboard(•T 1 ,rows_b,columns_b); 
end; 

OriginalTestPattern := TestPattern; 
end; 

{ XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX#XXXXXXXXXXXXXXXX#XXXXXXXXXXXXXXX#XX#XX#XX#X } 

{ XXXXXX#XXXXXXXXXX#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX#XXXXXXXXXXXXXXXX#XXXXXXXXX#XXX } 
procedure ComputeEnergy; 

var 

sum : real; 
temp: oneD; 

pattern_n,len_A,len_B,tempi: integer; 

begin 
sum := 0.0; 
energy := 0.0; 

for pattern_n : = 1 to num_patterns do 
begin 

for len_B :=lto Length_B do 
begin 

temp[len_B] :» 0; 
for len_A : = 1 to Length_A do 
begin 

tempi :s ( memory[len_A,len_B] - 0 ); 

temp[len_B] := temp[len_B] Pattern_A[pattern_n,l,lea_A] * tempi; 
end; 
end; 

for len_B : = 1 to Length_B do 

sum :s sum + temp[leruB] # Pattern_B[pattern_n,l,len_B]; 
energy := -sum; 
end; 
end; 

{ MKXNKXKKKMKXKXXKXKKXKNKXXKKNNXXNNKMNNMNNHMNMIOnHtKXXXNXXNNMXKMMKlHIKKMXiHnntKXttttKfHHtttllKtftt } 

{ XXXXXKXXXXXXXXXXXXXXXXXXXXXXXXXKXXKXMMNKKXXXXKXXXXXXXKXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX } 
procedure Hamming; 

var 

n,J: integer; 
begin 

for n : * l to num_patterns do 
Ham[n] 0; 

MinHam := 1; 

for n :* 1 to num_patterns do 
begin 

if test_type = 'A' then 
begin 

for J : s l to Length_A do 
if Pattern_A[n,lJ] <> 0riginalTestPattern[J] 
thenHam[n] :»Ham[n]+l; 
if Ham[n] < Ham[MinHam] then MinHam :■ n; 


continued 
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end 

else 

begin 

for J : = 1 to LengthJB do 

if Pattern_B[n,l,J] <> OriginalTestPattern[j] 
thenHam[n] :=Ham[n] + l; 
if Ham[n] < Ham[MinHam] then MinHam : = n; 
end; 
end; 
end; 

{ ************************************************************************************** 
procedure status(x,y:integer;TxT:textin); 

var first:char; 
last :textin; 

begin 

TextBackground(blue); { if status is not called from StatusLine } 

first := copy(TxT,l,l); 

last :* copy(TxT,2,(length(TxT) - 1)); 

GoToXY(x,y); Textcolor(white); write(first); 

GoToXY(x+l,y); Textcolor(yellow); write(last); 

end; 

{ ************************************************************************************** 

{ ************************************************************************************** 
Procedure StatusLine; 

var i:integer; chrchar; 

begin 

TextBackground(blue); 

GoToXY(1,23); 

for i : = 1 to screencolumns do write(' '); { status line background } 

GoToXY(12,23); TextColor(Yellow); 

write(’STATUS LINE - First letter of choice and RETURN selects:'); 

GoToXY(1,24); 

for i : = 1 to screencolumns do write(' '); { status line background } 

Status(15,24,’Quit'); 

if SynchMode = True then Status(34,24, 'Synch ') 
else Status(34,24,'Asynch'); 

Status(55,24, 'Ham dist'); 

GoToXY(15,20); 

write('Select execution Mode — Synchronous/Asynchronous'); 
repeat 
begin 

read(kbd,ch); 

if ch in ['s', 'S'] then SynchMode := True; 
if ch in [ 'a',' A' ] then SynchMode :« False; 
end; 

until ch in ['a','A','s','S']; 
if SynchMode = True then Status(34,24, 'Synch ') 
else Status(34,24,'Asynch'); 

Textbackground(lightcyan);Textcolor(blue); 

GoToXY(15,20); 

write(' '); 

end;{StatusLine} 

{ ************************************************************************************** 

{ ************************************************************************************** 
Procedure TurnPCcursorOff; 

{get rid of regular cursor} 
type 

RegPack = record 

AL,AH,BL,BH,CL,CH,DL,DH : Byte; 

BP,SI,DI,DS,ES,Flags : Integer; 
end; 
var 

Regs : RegPack; 
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begin 

with Regs do 

begin 

AH: =$1; CH:=16;CL:= 0; 

Intr($10,Regs); 
end; 

end;{TurnPCcursorOff} 

{ iHHHHHHMHHHHHHHHHMHMtttIHHHMHHMHHHtIHHHHHHHHttHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHj ] 

Procedure TurnPCcursorOn; 

{turnon regular cursor} 
type 

RegPack = record 

AL,AH,BL,BH,CL,CH,DL,DH : Byte; 

BP,SI,DI,DS,ES,Flags : Integer; 
end; 
var 

Regs : RegPack; 

begin 

with Regs do 

begin 

AH:=$1; CH: =7;CL: *» 9; {start line>end means cursor off} 

Intr($10,Regs); 
end; 

end; {TurnPCcursorOn} 

{ **##*##**######*##*######«***#* KM* | 

procedure BipolarizeB; ; 

var 

index:integer; 
begin 

for index : = 1 to Length_B do 
begin 

if Pattern_B[Pattern_Number,1,index] ■ 0 
then BipolarJ3[Pattern_Number,1,index] : * -l 
else BipolarJ3[Pattern_Numbcr,1,index] : = 1; 

end; 

end; 

{ a******####*#####*######*###*#*******a k*xx»*xxkxx##xxx#x#######x#xx########## # ## m ## m ^ ] 

procedure BipolarizeA; ; 

var 

index:integer; 
begin 

for index : = 1 to LengtluA do 
begin 

if Pattern_A[Pattern_Number,l,index] ■ 0 
then Bipolar_A[Pattern_Number # l # index] :■ -1 
else Bipolar_A[Pattern__Number,l, index] :■ 1; 

end; 

end; 

{ IHHHHHHHHHHMHMMMHiXMXJHHHHHHHHHHHHHtaaJtaiUHHMHHHHHHHHHHHHHHHHHHHHHHHHHMHHHHHHHHHHHHHHHMHt } 

procedure Memorize_Bipolar; ; 

var 

patterns, leruA,len_B, temp : integer; 
begin 

GoToXY(4,bottomline + 2 ) ; 

write(' # Please wait - Bipolarization in Progress * •); 
for pattern_n : = 1 to num_patterns do 
for len__A : ■ 1 to Length_A do 
for len_B : = 1 to LengthJB do 
memory[len_a,len_b] := memory [ len_a , len_b] + 

bipolar_a[pattern_n,l,len_a] * 
bipolar__b[pattern_n,l,len_b]; 

continued 
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end; 

{ *##*##**##*###**###**###***####*0##*#####**#*#**#*#******##*#***#*#************#***** } 

{ ***##**####*##*#**#*o##**##o*o##*###*##*##***##*####*####**##**#*#**#**####*##***** } 

function ChecklfKeypressed: boolean; 

var 

ch:char; n,keyint: integer; 
begin 

if not(keypressed) then ChecklfKeypressed := False 
else 
begin 

read(kbd,ch); 
keylnt := ord(ch); 
case keyint of 

113,81 : ChecklfKeypressed :=True; 

{ Q or q for Quit has been pressed } 

115,83 : begin (Sors) 

Synchmode := True; 

Status(34,24,'Synch '); 

ChecklfKeypressed := False; {continues execution} 
end; 

97,65 : begin {A or a} 

Synchmode : = False; 

Status(34,24,'Asynch'); 

ChecklfKeypressed := False; {continues execution} 
end; 

104,72 : begin 

for n : = 1 to num_patterns do 
begin 

GoToXY(l6,18+(n-1)); 

write('Hamming Distance for Pattern ' ,test_type); 
writeln('',n,' is :',Ham[n]); 
end; 

GoToXY(20,22); 

writeln( 'Press any key to continue '); 
repeat until keypressed; 

GoToXY(20,22); 

writeln( 1 '); 

ChecklfKeypressed :* False; {continues execution} 
for n : = 1 to num_patterns do 
begin 

GoToXY(l6,18+ (n-1)); 
write(' '); 

writeln(' '); 

end; 

end; 

else ChecklfKeypressed := False; 

{ no action taken } 

end; { end case } 
end; 

end; 

{ *############*#####*#########*###»########################*########»######*####*###### } 

Procedure Bammer(Test_Pat:oneD; test_now:char; 

lengl,leng2:integer); 


var 

Memory_Transpose :Square; 

maxrow,n,k,i,J,m,y,Start,Finish :integer; 
BinVect :0neD; 

begin 

Textbackground(lightcyan); 

TextColor(blue); 

GoToXY(lefttwo,TL - 2); 
write('MATRIX A'); 

G 0 T 0 XY(leftthree,TL - 2); 
write('MATRIX B'); 
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Textbackground(1ightgray); 

TextColor(magenta); 

if Synchmode = True then 

begin { Synchronous Mode prints out all Neurons } 

for j :» 1 to lengl do 
OutPatt[J] := 0; 

case test_now of 
'A' : begin 

B_Check :* Test_Pat; 

for i : = 1 to leng2 do 
if Test_Pat[i] * 0 then BinVect[i] :=-l 
else BinVect[i] := 1; 

for i :» 1 to lengl do 
for J : = 1 to leng2 do 
Memory_Transpose[J,i] :- Memory[i,J]; 

for J : = 1 to lengl do 
for i : = 1 to leng2 do 

0utPatt[J] :*0utPatt[J] + BinVect[i] # Memory_Transpose[i,J]; 

end; 

•B' : begin 

A^Check : = Test_Pat; 

for i : = 1 to leng2 do 
if Test_Pat[i] « 0 then BinVect[i] :=-l 
else BinVect[i] := 1; 

for i : = 1 to lengl do 
for j : * 1 to leng2 do 

0utPatt[i] := 0utPatt[l]+ BinVect[j] #Memory[j,i]; 

end; 

end; { end case } 

for J : * 1 to lengl do 
begin 

if (0utPatt[j] - threshold) > 0 then TestPattern[J ] := 1 
else 

if (OutPatt[J] - threshold) < 0 then TostPattern[j] 0 
else 

case test_now of 

'A' : TestPattern[J] :=/L.ChecklJ]; 

'B' : TestPattern[J] := B_CheckfJ]; 
end; { end case } 
end; { end for Start to Finish } 

case test_now of 
•A': 

begin 

k:«TL-l; { prints out matrix A ) 

for y : ■ 0 to LengtluA - 1 do 

begin 

i : = y mod Columns_A; 
if i ■ 0 then k : = k + l; 

GoToXY(lefttwo + i,k); 

if TestPattern[y + 1] ■ 1 then write(ohr(177)) 
else write(chr(249)); 

end; 

k:»TL-l; { prints out matrix B } 

for y : = 0 to Length_B - 1 do 

begin 

i : = y mod Columns_B; 
if i = 0 then k :*k + l; 

GoToXY(leftthree + i,k); 
if Test_Pat[y+ 1] a l then writo(chr( 177)) 
else write(chr(249)); 

end; 

end; { 'A' ) 

•B*: 
begin 


continued 
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k : = 1; { prints out matrix A } 

for i : = 0 to Rows_A - 1 do 

begin 

for j : = 0 to Columns_A -1 do 
begin 

GoToXY(lefttwo + j,TL +i); 
if Test_Pat[k] = 1 then write(chr( 177)) 
else write(chr(249)); 

k := k +1; 
end; 
end; 

k : = 1; { prints out matrix B } 

for i : = 0 to Rows_B - 1 do 

begin 

for j : = 0 to Columns_B - 1 do 
begin 

GoToXY(leftthree + j,TL + i); 
if TestPattern[k] = 1 then write(chr(177)) 
else write(chr(249)); 

k := k + 1; 
end; 
end; 

end; { »B' } 

end; { case test_now of } 
end; { if Synchmode true } 

if Synchmode = False then 

begin { Asynchronous Mode prints out one Neuron } 

for j : = 1 to lengl do 
OutPatt[j] :* 0; 

Case test_now of 
'A' : begin 

B_Check :=Test_Pat; 


for i : = 1 to leng2 do 
if Test_Pat[i] = 0 then BinVect[i] : = -l 
else BinVect[i] := 1; 


for i : = 1 to lengl do 
for j : = 1 to leng2 do 
Memory_Transpose[J,i] := Memory[i,j]; 

Start := Random(lengl); 
if Start = 0 then Start : = lengl; 


for i : = 1 to leng2 do 
OutPatt[Start] := OutPatt[Start] + 

BinVect[i] * Memory_Transpose[i,Start]; 


end; 


*B' : begin 

/LCheck : = Test_Pat; 


for i : = 1 to leng2 do 
if Test_Pat[i] ■ 0 then BinVect[i] :*-l 
else BinVect[i] : = 1; 

Start : = Random(lengl); 
if Start = 0 then Start : = lengl; 


end; 


for i : ■ 1 to leng2 do 
OutPatt[Start] : = OutPatt[Start] + 

BinVect[i] * Memory[i,Start]; 

end; 

{ end case } 


for J : ■ 1 to lengl do 
begin 

if (OutPatt[J ] - threshold) > 0 then TestPattern[J ] : * 1 
else 

if (OutPatt[J] - threshold) < 0 then TestPattern[J] :■ 0 
else 
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case test_nov of 

'A' : TestPattern[J] := A_Check[J]; 

'B' : TestPattern[J] :=B_Check[J]; 
end; { end case } 
end; { end for Start to Finish } 

case test_now of 
'A 1 : begin 

k:=TL-l; { prints out matrix A } 

for y : • 0 to Length_A - 1 do 

begin 

1 : s y mod Columns_A; 
if i = 0 then k := k + 1; 

GoToXY(lefttwo + i, k); 

if TestPattern[y + 1] = 1 then vrite(chr(177)) 
v else write(chr(249)); 

end; 

k : = TL - 1; { prints out matrix B } 
for y : = 0 to Length_B - 1 do 
begin 

i : = y mod Columns_B; 
if i * 0 then k :»k + l; 

GoToXY(leftthree + i, k); 
if Test_Pat[y + 1] - 1 then write(chr(177)) 
else write(chr(249)); 

end; 

end; { 'A r } 

'B' : begin 

k : 3 ^ { prints out matrix A } 

for i : = 0 to Rows_A - 1 do 

begin 

for j : = 0 to Columns_A - 1 do 
begin 

GoToXY(lefttwo + J,TL+ 1); 
if Test_Pat[k] - 1 then write(chr(177)) 
else vrite(chr(249)); 

k := k + 1; 
end; 
end; 

{ prints out matrix B } 

for i : = 0 to Rows_B - 1 do 
begin 

for J : = 0 to Columns_B - 1 do 
begin 

GoToXY(leftthree + J,TL+i); 
if TestPattern[k] - 1 then write(chr(l77)) 
else write(chr(249)); 

k := k +1; 
end; 

end; 

end; { »B' } 

end; { case test_now of } 
end; { end if Synchmode False } 

GoToXY(l,Bottomline + 2); 

TextBackground(lightcyan); 

TextColor(blue); 

end; 

{ .. J 

{ . . . » 

procedure Bam; ; 

begin 

GoToXY(1,1); TextColor(Red); 

v,rlte (' PROCESSING'); 

if test_type *'A'then • 

begin 
repeat 


continued 
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Bammer(TestPattern,' B', Leng thJB, Lengths); 

Bammer(TestPattern,’A',Length_A,Length_B); 
until ChecklfKeypressed; 
end 
else 
begin 
repeat 

Bammer(TestPattern,'A',Length_A,Length_B); 

Bammer(TestPattern,'B',Length_B,Length_A); 
until ChecklfKeypressed; 
end; 

end; 

{ XXXXXXX##XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX#XXXXXX#XXXX*XXXXX#XX#XXXXX#X 

function DataFromFile:boolean; 
begin 

textbackground(lightcyan); 

clrscr; { clears out any predefined user background } 

textmode(C80); 
textbackground(lightcyan); 
textcolor(red); 

GoToXY(8,4); 

write('B I D I R E C T I 0 N A L ASSOCIATIVE MEMORY’); 

DataFromFile :* False; 

GoToXY(l,8); 

if yes(' Do you want to read the patterns from a file ? ') then 

begin 

GoToXY(l,9); 

write(’ Enter the filename to read from: ’); 

readln(filename); 

assign(inputfile,filename); 

{*i-} 

reset(inputfile); 

{$i+} 

DataFromFile :«True; 
if not(ioresult = 0) then 
begin 

GoToXY(l,9); Textcolor(Red + Blink); 
writeln( ’Unable to open file '); 
exit; 
end; 
end; 
end; 

{ xxxxxxxxxxxxxxxxx#xxxxxxxxxxxxxxxxxxxxx#x#xxxxxxxxxx#xxxxxxxxxx#xxxxxxx#x#xxxxxxxxx#xx 

procedure ReadlnFile; 
var 

temp:integer; ch:char; 
begin 

TurnPCcursorOff; 
readln(inputfile,num_patterns); 
readln(inputfile,Rows_A); 
readln(inputfile,Columns_A); 
readln(inputflie,Rows_B); 
readln(inputfile,Columns_B); 

Length_A := Rows_A * Columns_A; 

Length^B :* Rows_B * columns_B; 
clrscr; 

textcolor(blue); TL := topline; 

GoToXY(l,l); 

write( 'Reading Patterns from file: ',filename); 

GoToXY(leftone,TL - 2) ; 
write('MATRIX A'); 

GoToXY(le fttwo,TL - 2); 
write('MATRIXB'); 
textbackground(lightgray); 

textcolor(magenta); , 

for Pattern_Number :» 1 to num_patterns do 

begin 

GoToXY(13 , bottomline+1); 
write('Pattern ' ,Pattern_Number); 
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TL : = topline; LL : = leftone; 

for AR :* 1 to Rows_A do 
begin 

for AC : = 1 to Columns_A do 
begin 

PAC := LL + AC - 1; 

PAR TL + AR - 1; 

GoToXY(PAC,PAR); 
read(inputfile,temp); 
if temp = 1 then write(chr( 177)) 
else write(chr(249)); 

end; 

end; 

LL := lefttwo; TL := topline; 
for AR : = 1 to Rows_B do 
begin 

for AC : = 1 to Columns_B do 
begin 

PAC := LL + AC - 1; 

PAR : = TL + AR - 1; 

GoToXY(PAC,PAR); 
read(inputfile,temp); 
if temp = 1 then write(chr(l77)) 
else write(chr(249)); 

end; 

end; 

LL :* leftone; TL := topline; 

SaveSoreen('A',Rovs_A,Columns_A)j 
LL := lefttwoj TL := topline j 
SaveScreen('B*,Rovs_B,Columns_B); 

BipolarizeB; 

BipolarizeA; 

GoToXY(8,bottomline + 2); Textbackground(lightcyan); 

Textcolor(red); write( 'Press any key to continue reading patterns.'): 
repeat until keypressed; 
read(kbd,ch); 

GoToXY(8,bottomline + 2); Textbackground(lightcyan); 
write ( * *); { erase above } 

Textcolor(magenta); Textbackground(lightgray); 

end; { for PatterruNumber } 

textcolor(blue); Textbackground(lightcyan); 

GoToXY(4, bottomline + 1); TurnPCcursorOn; 

writeln( 'Enter the threshold of neuron activation;'); 

GoToXY(4,bottomline + 2); 

write('Value must be in range; - »,maxentries,', + »,maxentries,' »); 
readln(threshold); TurnPCcursorOff; 

GoToXY(4, bottomline + 1); 
writeln(' •). 

end; 

Procedure WriteToFile; ; 

var n,z;integer; 

begin 

if yes(' Do you want to save the memory patterns to a file ? •) then 
begin 

write( 1 Enter the filename to save patterns to: 1 ); 
readln(filename2); 
assign(outfle,filename 2 ); 
rewrite(outfle); 
writeln(outfie,num_patterns); 
writeln(outfle,Rows_A); 
writeln(outfle,Columns_A); 
writeln(outfle,Rows_B); 
writeln(outfle,Columns_B); 
for n : * 1 to num_patterns do 
begin 

for z : ■ 1 to Length_A do 
write(outfle,Pattern_A[n,l,z],• •); 
writeln(outfle); 


continued 


BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 113 










September 

for z : = 1 to LengthJB do 
write(outfle,Pattern_B[n,l,z],' '); 
writeln(outfle); 
end; 

close(outfle); 

end; 

end; 

{ a#################*##*###############*#############################*###########*###### } 

{ a##**#***#########*##*###*****#***##*****#**#*#**#*###*##*#**#####*##**#*#*#********** } 

begin { MAIN } 

repeat { until not ’yes try another set of patterns ' } 

UseCurrentScreenSetup; 
if DataFromFile = False then 
begin { input is from the keyboard } 

Read_Row_and_Column_Values; 

SetMemoryToZero; 

clrscr; 

for Pattern_Number :« 1 to num_patterns do 
begin 

TL:= topline; LL:=leftone; 

DataFromKeyboard(' A',rows_a,columns_a); 

TL :« topline; LL := left two; 

DataFromKeyboard('B',rows_b,columns_b); 

BipolarizeB; 

BipolarizeA; 

if Pattern_Number <> num_patteros then EraseOldMatrices; 
end; 

end { input is from the keyboard } 
else { input is from the files } 

ReadlnFile; 

SetMemoryToZero; 

Memorize_Bipolar; 

ComputeEnergy; 

TuraPCcursorOn; 

repeat { until not yes 'another test pattern ' } 
zero_test; 

InputTes tPattem; 

Hamming; 

TumPCcursorOff; 

StatusLine; 

Bam; 

TuraPCcursorOn; 

WriteToFile; 

until not yes(' Do you want to try another test pattern ? '); 
until not yes(' Do you want to try another set of patterns ? '); 

TextMode; { returns screen to previous graphics color mode } 

clrscr; 

end. 


XFACE. INC From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


type 

mstring = string[100]; 
var 

outfile : text; 

FUNCTION yes(PROMPT:MSTRING): BOOLEAN; 
var 

ch : string[2]; 
begin 

(#$I-#)(*$R-#) 

repeat 

write(prompt,' (y/n) '); 
readln(ch); 

until (ch ='y') or (ch • 'Y') or (ch »'N') or (ch «'n') and (ioresult=0); 
(»$I+#)(#$R-f») 
yes :■ (ch »• y') or (ch «'Y'); 
end; 
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PROCEDURE setoutfile; 
var 

ch: char; 
begin 

(*$I-*)(*$R-*) 

repeat 

write('OUTPUTDESTINATION: P(rinterC(onsole : 
readln(ch); 

until (eh inCcVCVpVP']) and (ioresult = 0); 
case ch of 

'pVP' : ASSIGN(outfile, 'LST:'); 

'cVC' : ASSIGN(outfile, 'CON:'); 
end; (#case#) 

REWRITE(OUTFILE); 

(*$I+*)(*$R+#) 
end; (*setoutfile#) 


FUNCTION getnum(PROMPT:MSTRING; LOW,HIGH: INTEGER): INTEGER; 
var 

val : integer; 
begin 

VAL .*=-31695; 

(*$I-*)(*$R-*) 

repeat 

write(prompt,' (',low,'..»,high,'): •); 
readln(val); 

if (val < low) or (val > high) 
then writeln(' VALUE OUT OF RANGE '); 
if ioresult <> 0 

then writeln( 'WRONG DATA TYPE '); 
until (val >= low) and (val <= high) and (ioresult = 0); 
getnum := val; 

(#$I+#)(*$R+*) 

end; 

FUNCTION getchar(PROMPT:MSTRING) :CHAR; 
var 

ch : char; 
begin 

(*$I-*)(#$R-») 

repeat 

write(prompt); 
readln(ch); 

until (ch IN ['a>..'z','A'..'Z']) and (ioresult = 0); 
getchar := ch; 

(*$I+*)(»$R+*) 

end; 

FUNCTION getreal(PROMPT:MSTRING; LOW,HIGH:REAL) :REAL; 
var 

val : real; 
begin 

VAL := -31695.7; 

(»$I-*)(»$R-») 

repeat 

write(prompt,'(',low:3:l,'.. 1 ,hlgh:3:l,'): '); 
readln(val); 

if (val < low) or (val > high) or (ioresult <> 0) 
then writeln(' Data incorrect type or out of range '); 
until (val <= low) and (val <* high) and (ioresult ** 0); 
getreal :« val; 

(#$I+#)(#$R+#) 

end; 


con tinned 
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BAM.BAS From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


1000 CLS 
1010 PRINT 
1020 PRINT 
1030 PRINT 
1040 PRINT " 

1050 PRINT " 

1060 PRINT " 

1070 PRINT " 

1080 PRINT " 

1090 PRINT " 

1100 PRINT " 

1110 PRINT " 

1120 PRINT " 

1130 PRINT " 

1140 PRINT " 

1150 PRINT " 

1160 PRINT 
1170 PRINT 
1180 PRINT 
1190 PRINT 
1200 PRINT " 

1210 S$=INKEY$ 

1220 IF LEN(S$) =0 THEN GOTO 1210 

1230 IF S$<>"Y" AND S$<>"y" THEN GOTO 1760 

1240 CLS 

1250 PRINT 

1260 PRINT " USING THE BAM DEMONSTRATION PROGRAM" 

1270 PRINT 

1280 PRINT " - CHANGE NETWORK PARAMETERS to set new values of the A and B" 

1290 PRINT " dimensions, the number of cells updated per iteration of the" 
1300 PRINT " network, and the percentage of elements to change state when" 
1310 PRINT " random noise is added to the A and B fields. The maximun" 

1320 PRINT " size of the A or B fields is 144 elements (12x12)." 

1330 PRINT 

1340 PRINT " - CLEAR NETWORK fills the matrix M with 0. All stored patterns" 
1350 PRINT " will be lost when this command is executed, so be sure to" 

1360 PRINT " save the M matrix before executing this command." 

1370 PRINT 

1380 PRINT " - LOAD MEMORY MATRIX M displays all current BAM interconnect" 
1390 PRINT " matrix files stored on disk. Enter the desired filename" 

1400 PRINT " to load that file into the M matrix." 

1410 PRINT 

1420 PRINT " - SAVE MEMORY MATRIX M to store the current M matrix to a disk" 
1430 PRINT " file. The dimensions of the A and B fields are also saved." 

1440 PRINT 
1450 PRINT 

1460 PRINT " PRESS ANY KEY TO CONTINUE" 

1470 S$=INKEY$ 

1480 IF LEN(S$)*0 THEN GOTO 1470 
1490 CLS 
1500 PRINT 

1510 PRINT " - EDIT/RUN NETWORK to input new patterns to the A and B fields." 
1520 PRINT " Once input, the network can either learn the new pattern or" 
1530 PRINT " execute one or more iterations of the network. 

1540 PRINT 

1550 PRINT " - LEARN CURRENT PATTERN takes the current state of the A and B" 
1560 PRINT " fields and changes the M matrix to learn this pattern. The" 

1570 PRINT " cursor will disappear until this operation is complete. 

1580 PRINT 

1590 PRINT " - ADD RANDOM NOISE will flip the state of a certain percentage" 
1600 PRINT " of elements in both the A and B fields. The percentage is" 

1610 PRINT " set in the NETWORK PARAMETERS. This can be used to see how" 

1620 PRINT " different a pattern can be to still be recalled. 

1630 PRINT 

1640 PRINT " - RUN THE NETWORK will execute two complete iterations of the" 
1650 PRINT " network when the parameter is set for synchronous operation." 
1660 PRINT " When the number of cells updated per iteration Is greater " 

1670 PRINT " than 0, 10 iterations of the network are executed. At each" 

1680 PRINT " iteration, only the number of cells specified In the parameter" 
1690 PRINT " are updated per field." 

1700 PRINT 
1710 PRINT 


X****************************************************************” 


* *« 

* BIDIRECTIONAL ASSOCIATIVE MEMORY *» 

* DEMONSTRAION PROGRAM #" 

* *» 

* (C) COPYRIGHT 1987 LOGICAL DESIGNS CONSULTING INC. *" 

* 3229 ERIE ST. SAN DIEGO, CA 92117 #" 

* (619) 276-3955 *" 

* *» 

* BY DUANE DESIEN0 #" 

* x» 


**x*x******x*****xx**x**x******xxx*xxx*xxxxxx**xxxxxxx**xxxx*xxx*» 


PRESS (Y) FOR INSTRUCTIONS" 
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PRESS ANY KEY TO CONTINUE" 


1720 PRINT " 

1730 S$=INKEY$ 

1740 IF LEN(S$) =0 THEN GOTO 1730 
1750 REM 

1760 ON ERROR GOTO 4720 

1770 DIM A$(144),B$(144),XJC(144),Y!J(144),M$(144,144) 
1780 AXSIZE=12: AYSIZE=12: BXSIZE-12: BYSIZE=12 
1790 CLS 
1800 KEY OFF 
1810 PRINT " 

1820 PRINT " 

1830 PRINT 
1840 PRINT 
1850 PRINT " 

1860 PRINT 
1870 PRINT 
1880 PRINT 
1890 PRINT " 

1900 PRINT 
1910 PRINT " 

1920 PRINT " 

1930 PRINT " 

1940 PRINT " 

1950 PRINT » 

1960 PRINT " 

1970 PRINT 
1980 INPUT " 


BIDIRECTIONAL ASSOCIATIVE MEMORY " 
DEMONSTRATION PROGRAM" 


BY DUANE DESIENO" 


MAIN MENU" 

1 - CHANGE NETWORK PARAMETERS" 

2 - CLEAR NETWORK" 

3 - LOAD MEMORY MATRIX M" 

4 - SAVE MEMORY MATRIX M" 

5 - EDIT/RUN NETWORK" 

6 - QUIT" 

INPUT CHOICE (1-6): CHOICE 


1990 ON CHOICE GOSUB 2010,2370,4240,4480,3000,4750 
2000 GOTO 1790 ’THIS IS THE MAIN LOOP OF THE PROGRAM 
2010 REM IHHHHHHHHUHHHMHMHHHHHHMHHHHHHHHtiHHHHHHHHHHHHHHHHHHHUj 
2020 REM CHANGE NETWORK PARAMETERS 

2030 REM 
2040 CLS 
2050 LOCATE 5,1 


CURRENT NETWORK PARAMETERS" 


1 - A FIELD X DIMENSION 

2 - A FIELD Y DIMENSION 
3-B FIELD X DIMENSION 

4 -B FIELD Y DIMENSION 

5 - NUMBER OF CELLS CHANGED PER » 

ITERATION ASYNCHRONOUS) 

6 - RANDOM NOISE PERCENTAGE 

7 - RETURN" 


2060 PRINT " 

2070 PRINT 
2080 PRINT 
2090 PRINT " 

2100 PRINT " 

2110 PRINT " 

2120 PRINT " 

2130 PRINT " 

2140 PRINT " 

2150 PRINT " 

2160 PRINT " 

2170 PRINT 

2180 INPUT » ENTER CHOICE :»; CHOICE 

2190 IF CH0ICE=7 THEN GOTO 2290 
2200 INPUT " ENTER NEW VALUE :"; NVAL 

2210 ON CHOICE GOTO 2230,2240,2250,2260,2270,2280 
2220 RETURN 

2230 AXSIZE=NVAL: GOTO 2010 ' LOOP TILL DONE 

2240 AYSIZE=NVAL: GOTO 2010 

2250 BXSIZE=NVAL: GOTO 2010 

2260 BYSIZE=NVAL: GOTO 2010 

2270 ASYN=NVAL: GOTO 2010 

2280 NOISE=NVAL: GOTO 2010 

2290 IF AXSIZE#AYSIZE>144 THEN PRINT "A FIELD TOO URGE";: GOTO 2050 
2300 IF AYSIZE>16 THEN PRINT "A FIELD Y DIM TOO URGE";: GOTO 2050 
2310 IF BXSIZE#BYSIZE>144 THEN PRINT "B FIELD TOO LARGE";: GOTO 2050 
2320 IF BYSIZE>16 THEN PRINT "B FIELD Y DIM TOO URGE";: GOTO 2050 
2330 RETURN ’ END OF CHANGE NETWORK PARAMETERS 

2340 REM a#########################################***####### 

2350 REM CLEAR NETWORK MATRIX M,A,B 

2360 REM 

2370 FOR 1=1 TO 144 
2380 A*(I)=0 

2390 B*(I)=0 

2400 NEXT I 

2410 FOR 1=1 TO AXSIZE#AYSIZE 'CLEAR THE MEMORY MATRIX M 

2420 FOR J=1 TO BXSIZE#BYSIZE 

2430 M*(I,J)=0 

2440 NEXT J 

2450 PRINT"."; 


: ";AXSIZE 
: ";AYSIZE 
: ";BXSIZE 
: ";BYSIZE 

: ";ASYN 
: ";NOISE 


continued 
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2460 NEXT I 

2470 RETURN ■ END OF CLEAR NETWORK 

2480 REM a######*###*###*#**##**######*###*##* 

2490 REM DISPLAY A AND B FIELDS 

2500 REM a#################################### 

2510 CLS 

2520 LOCATE 1,19: PRINT "A FIELD"; 

2530 LOCATE 1,59: PRINT "B FIELD"; 

2540 REM **** DRAW BOX AROUND A FIELD **#* 

2550 LOCATE 3,15: PRINT CHR$(218) 

2560 FOR 1=1 TO AXSIZE: LOCATE 3,15+1: PRINT CHR$(196);: NEXT I 
2570 PRINT CHR$(191); 

2580 FOR J=1 TO AYSIZE 

2590 LOCATE 3+J, 15: PRINT CHR$(179); 

2600 LOCATE 3+J,15+AXSIZE+l: PRINT CHR$(179); 

2610 NEXT J 

2620 LOCATE 3+AYSIZE+l, 15: PRINT CHR$( 192); 

2630 FOR 1=1 TO AXSIZE: LOCATE 3+AYSIZE+l, 15+1: PRINT CHR$( 196);: NEXT I 
2640 PRINT CHR$(217); 

2650 REM #«*« DRAW BOX AROUND B FIELD ***# 

2660 LOCATE 3,55: PRINT CHR$(218) 

2670 FOR 1=1 TO BXSIZE: LOCATE 3,55+1: PRINT CHR$(196);: NEXT I 
2680 PRINT CHR$(191); 

2690 FOR J=1 TO BYSIZE 

2700 LOCATE 3+J,55: PRINT CHR$(179); 

2710 LOCATE3+J,55+BXSIZE+l: PRINTCHR$(179); 

2720 NEXT J 

2730 LOCATE 3+BYSIZE+l, 55: PRINT CHR$( 192) 

2740 FOR 1=1 TO BXSIZE: LOCATE 3+BYSIZE+l,55+1: PRINT CHR$( 196);: NEXT I 
2750 PRINT CHR$(217); 

1. LEARN CURRENT PATTERN"; 

ARROW KEYS TO MOVE CURSOR"; 

2. ADD RANDOM NOISE"; 

A ORB TO SWITCH FIELDS" 

3. 


2760 LOCATE 21,1:PRINT "OPTIONS: 
2770 LOCATE 21,41: PRINT " 

2780 LOCATE 22,1:PRINT " 

2790 LOCATE 22,4l:PRINT " 

2800 LOCATE 23,1:PRINT " 

2810 LOCATE 23,41:PRINT " 

2820 LOCATE 24,1:PRINT " 

2830 LOCATE 24,4l:PRINT " 

2840 LOCATE 25,1:PRINT » 


2870 

2880 

2890 

2900 


2940 

2950 

2960 

2970 


RUN THE NETWORK"; 

+ TO SET LEVEL TO 1"; 

4. CLEAR A AND B FIELDS"; 

-TO SET LEVEL TOO"; 

ESC. RETURN TO MAIN MENU"; 

2850 REM **** DISPLAY THE A FIELD ARRAY IN THE BOX *»** 

2860 FOR J=1 TO AYSIZE 
FOR 1=1 TO AXSIZE 
LOCATE 3+J, 15+1 

PRINT CHR$(219*A*((J-1)*AXSIZE+I)); 

NEXT I 
2910 NEXT J 

2920 REM ***# DISPLAY THE B FIELD ARRAY IN THE BOX **** 

2930 FOR J=1 TO BYSIZE 
FOR 1=1 TO BXSIZE 
LOCATE 3+J,55+1 

PRINT CHR$(219*B*((J-1)#BXSIZE+I)); 

NEXT I 
2980 NEXT J 
2990 RETURN 

3000 REM a###########################*##########*###########* 

3010 REM EDIT THE A AND B FIELDS 

3020 REM *tt*ttttfto**tttt*ttft**tttt*JUtt*tttt*ft**«**ft******tf****tf****** 

3030 GOSUB 2480 ' DISPLAY THE FIELDS BEFORE EDITING 

3040 PX=1: PY=1: FLD=0 'START ON A FIELD UPPER LEFT CORNER 
3050 S$=INKEY$ • GET KEYBOARD ENTRY 

3060 LOCATE 3+PY, 15+PX+40*FLD ' POSITION CURSOR IN FIELD BOX 

3070 PRINT "*"; 

3080 FOR ZZ=1 TO 4: NEXTZZ 

3090 LOCATE 3+PY, 15+PX+40#FLD 

3100 IF FLD=0 THEN XSIZE=AXSIZE: YSIZE=AYSIZE 

3110 IF FLD=1 THEN XSIZE=BXSIZE: YSIZE=BYSIZE 

3120 OFS=((PY-1)#XSIZE+PX) 

3130 IF FLD=0 THEN STAT=A*(OFS) ELSE STAT=B£(OFS) 

3140 PRINT CHR$(219#STAT); 

3150 IF LEN(S$)*2 THEN S$=RIGHT$(S$,1) 

3160 IF S$=CHR$(77) THEN PX=PX+1 

3170 IF S$=CHR$(75) THEN PX=PX-1 

3180 IF S$=CHR$(72) THEN PY=PY-1 

3190 IF S$=CHR$(80) THEN PY=PY+1 

3200 IF S$="A" OR S$="a" THEN FLD=0: PX=1: PY-1 

3210 IF S$*"B" OR S$*"b" THEN FLD=1: PX-1: PY=1 

3220 IF S$="+" AND FLD=0 THEN AJt(OFS) =1 
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3230 IF S$="+" AND FLD=1 THEN B£(0FS)=1 
3240 IF S$="-" AND FLD=0 THEN AJt(OFS) =0 
3250 IF S$="-" AND FLD=1 THEN BJf(OFS) =0 
3260 IF S$="l" THEN GOSUB 3370 
3270 IF S$="2" THEN GOSUB 3530 
3280 IF S$="3" THEN GOSUB 3660 
3290 IF S$="4" THEN GOSUB 4150 
3300 IF PX<1 THEN PX=1 


' LEARN CURRENT PATTERN 
' ADD RANDOM NOISE TO PATTERN 
' RUN THE NETWORK 
r CLEAR THE A AND B FIELDS 


3310 IF PX>XSIZE THEN PX=1: PY=PY+1 
3320 IF PY<1 THEN PY=1 
3330 IF PY>YSIZE THEN PY=YSIZE 
3340 IFS$=CHR$(27) THEN RETURN 
3350 FOR ZZ=1 TO 4: NEXT ZZ 
3360 GOTO 3050 

3370 REM #################################################### 

3380 REM LEARN CURRENT PATTERN IN A AND B FIELDS 

3390 REM a######*####*###*########*############*######*###### 

3400 FOR 1=1 TO AXSIZE»AYSIZE • TRANSFER A FIELD TO BIPOLAR X FIELD 

3410 IF A*( I) =0 THEN X*( I) =-l ELSE X*( I) =1 
3420 NEXT I 

3430 FOR 1=1 TO BXSIZE#BYSIZE ' TRANSFER B FIELD TO BIPOLAR Y FIELD 

3440 IF B£(I)=0 THEN Y*(I) =-l ELSE Y*(I) =1 
3450 NEXT I 

3460 REM **** THE CORRELATION MATRIX M IS UPDATED HERE *#*# 

3470 FOR J=1 TO BXSIZE#BYSIZE 
3480 FOR 1=1 TO AXSIZE#AYSIZE 
3490 M*(I,J)=M*(I,J) + X*(I)*Y*(J) 

3500 NEXT I 
3510 NEXT J 
3520 RETURN 


3530 REM 

3540 REM add RANDOM NOISE TO THE A AND B FIELDS 

3550 REM 

3560 FOR 1=1 TO AXSIZE#AYSIZE 
3570 IF 100#RND>=NOISE THEN 3590 

3580 IF A*( I) =0 THEN A*( I) =1 ELSE A*(I) =0 • FLIP THE STATE 

3590 NEXT I 

3600 FOR 1=1 TO BXSIZE#BYSIZE 
3610 IF 100#RND>=NOISE THEN 3630 

3620 IF B£(I)=0 THEN B*(I) =1 ELSE BJt(I)=0 'FLIP THE STATE 
3630 NEXT I 

3640 GOSUB 2850 ' UPDATE THE A AND B FIELD DISPLAYS 

3650 RETURN 


3660 REM 

3670 REM RUN ITERATIONS OF THE NETWORK 

3680 REM *******############################################# 

3690 IF ASYN=0 THEN GOTO 3940 

3700 REM #### PERFORM ASYNCHRONOUS UPDATE OF ASYN RANDOM NEURONS/FIELD #*## 
3710 FOR CC=1 TO 10 ' LIMIT THE NUMBER OF ASYNCHRONOUS ITERATIONS 

3720 FOR K=1 TO ASYN 

PIK=INT((AXSIZE#AYSIZE)#RND+1) 

TSUM = 0 

FOR J=1 TO BXSIZE*BYSIZE ' UPDATE A FIELD NEURON 

TSUM = TSUM + B*(J)#M*(PIK,J) 

NEXT J 

IF TSUM>0 THEN A£(PIK)=1 ' THRESHOLD FUNCTION 

IF TSUM<0 THEN A*(PIK) =0 
NEXT K 

FOR K=1 TO ASYN 

PIK=INT((BXSIZE*BYSIZE)#RND+1) 

TSUM = 0 

FOR 1=1 TO AXSIZE#AYSIZE ' UPDATE B FIELD NEURON 

TSUM- TSUM + A*(I)#M*(I, PIK) 

NEXT I 

IF TSUM>0 THEN BJt(PIK) =1 ' THRESHOLD FUNCTION 

IF TSUM<0 THEN B%(PIK)=0 
NEXT K 

GOSUB 2850 ' WANT TO WATCH THE PROGRESS 

3910 NEXT CC 

3920 RETURN ' COMPLETED ASYN ITERATION 

3930 REM **** PERFORM SYNCHRONOUS UPDATE OF ALL NEURONS IN BOTH FIELDS #### 
3940 FOR CC = 1 TO 2 • ONLY TWO ITERATIONS NEEDED 

3950 FOR J«1 TO BXSIZE&BYSIZE 
TSUM = 0 

FOR 1=1 TO AXSIZE#AYSIZE • UPDATE B FIELD NEURON 


3730 

3740 

3750 

3760 

3770 

3780 

3790 

3800 

3810 

3820 

3830 

3840 

3850 

3860 

3870 

3880 

3890 

3900 


3960 

3970 
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3980 TSUM = TSUM + A*(I)#M*(I,J) 

3990 NEXT I 

4000 IF TSUM>0 THEN B% (J) =1 • THRESHOLD FUNCTION 

4010 IFTSUM<0 THEN B%(J)=0 

4020 NEXT J 

4030 FOR 1=1 TO AXSIZE*AYSIZE 
4040 TSUM = 0 

4050 FOR J=1 TO BXSIZE*BYSIZE ' UPDATE A FIELD NEURON 

4060 TSUM = TSUM + BJt(J)#M5C(I,J) 

4070 NEXT J 

4080 IF TSUM>0 THEN A*(I)=1 » THRESHOLD FUNCTION 

4090 IF TSUM<0 THEN A*(I)=0 

4100 NEXT I 

4110 GOSUB 2850 ' UPDATE THE A AND B FIELD DISPLAYS 

4120 NEXT CC < ITERATION OF BOTH FIELDS 
4130 RETURN 
4140 RETURN 

4150 REM KM#####*##########*###############*## 

4160 REM CLEAR THE A AND B FIELDS 

4170 REM ###########################*######### 

4180 FOR 1=1 TO 144 
4190 A*(I)=0 

4200 B*(I)=0 

4210 NEXT I 

4220 GOSUB 2850 ' UPDATE THE A AND B FIELD DISPLAYS 

4230 RETURN 

4240 REM a########################*##*####################### 

4250 REM LOAD CORRELATION MATRIX M FROM DISK FILE 

4260 REM ################*#####*###########*###########*##### 

4270 CLS 

4280 PRINT " CURRENT MEMORY MATRIX FILES ON DISK" 

4290 PRINT 
4300 FILES"#. BAM" 

4310 PRINT 
4320 PRINT 

4330 INPUT " ENTER FILENAME TO LOAD MEMORY MATRIX : FILESPEC$ 

4340 IF FILESPEC$ = " " THEN RETURN 

4350 IF INSTR(".",FILESPEC$) =0 THEN FILESPEC$ = FILESPEC$ + ".BAM" 

4360 OPEN FILESPEC$ FOR INPUT AS 01 
4370 INPUT 01, AXSIZE 
4380 INPUT 01, AYSIZE 
4390 INPUT 01, BXSIZE 
4400 INPUT 01, BYSIZE 
4410 FOR J=1 TO BXSIZE#BYSIZE 
4420 FOR 1=1 TO AXSIZE#AYSIZE 
4430 INPUT 01, M*(I,J) 

4440 NEXT I 
4450 NEXT J 
4460 CLOSE 01 
4470 RETURN 

4480 REM #######################lHHMHHHHHHHHHHHHHHHHHHHHHHHHHt 
4490 REM SAVE CORRELATION MATRIX M IX) DISK FILE 

4500 REM tHHHHHHHHHHUHHHHHHHHHHMHHHHHHHHHHHHUHHHHHUHHHUHHHUHHt 
4510 CLS 

4520 PRINT " CURRENT MEMORY MATRIX FILES ON DISK" 

4530 PRINT 
4540 FILES "#.BAM" 

4550 PRINT 
4560 PRINT 

4570 INPUT " ENTER FILENAME TO SAVE MEMORY MATRIX : "; FILESPEC$ 

4580 IF FILESPEC$ = " " THEN RETURN 

4590 IF INSTR(".",FILESPEC$) « 0 THEN FILESPEC$ • FILESPEC$ + ».BAH” 

4600 OPEN FI LESPECJ FOR OUTPUT AS #1 
4610 PRINT #1, AXSIZE 
4620 PRINT #1, AYSIZE 
4630 PRINT #1, BXSIZE 
4640 PRINT #1, BYSIZE 
4650 FOR J*1 TO BXSIZE*BYSIZE 
4660 FOR 1=1 TO AXSIZE*AYSIZE 
4670 PRINT #1, M*(I,J) 

4680 NEXT I 
4690 NEXT J 
4700 CLOSE #1 
4710 RETURN 

4720 IF ERL.4540 THEN PRINT "NO FILES": RESUME 4550 
4730 IF ERL=4300 THEN PRINT "NO FILES": RESUME 4310 
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4740 RESUME 1790 
4750 CLOSE 
4760 ON ERROR GOTO 0 
4770 END 


SORTELEM.MOD From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, 
September 1987. 


IMPLEMENTATION MODULE SortElemType; 

(* FROM FileDescriptor IMPORT FlleDescr; #) 

FROM InOut IMPORT in, ReadString, WriteString, WriteLn, Write; 

FROM Storage IMPORT ALLOCATE; 

FROM Strings IMPORT Length, Concat, Copy; 

CONST 

EOS = OC; (# End Of String #) 

TYPE 

ElemType = POINTER TO FileDescr; 

FileDescr = REC0RD(# File descriptor #) 
name : ARRAY [0. .8] OF CHAR; 
ext : ARRAY [0..3] OF CHAR; 
size : ARRAY [0..7] OF CHAR; 
date : ARRAY [0. .8] OF CHAR; 
time : ARRAY [0..6] OF CHAR 


comp : PROCEDURE (ElemType, ElemType): BOOLEAN; 

PROCEDURE compare (x, y: ElemType): BOOLEAN; 

BEGIN (# call the procedure currently #) 

RETURN comp(x,y) (# assigned to "comp"#) 

END compare; 

PROCEDUREcompName (rl, r2: ElemType): BOOLEAN; 

BEGIN 

RETURN Str ingComp (rl*. name, r2*. name) 

END compName; 

PROCEDURE compExt (rl, r2: ElemType): BOOLEAN; 

VAR tempi, temp2 : ARRAY [0. .12] OF CHAR; 

BEGIN (# compare by extension and then by name #) 

Concat(rl*.ext,".",tempi); Concat(tempi,rl*.name,tempi); 
Concat(r2*.ext,".",temp2); Concat(temp2,r2*.name,temp2); 
RETURN Str ingComp (tempi, temp2) 

END compExt; 


») 

*) 

*) 

*) 


PROCEDURE optionMenu; 

BEGIN 

WriteString("options:"); WriteLn; 

WriteString(" 1 to sort by filename"); WriteLn; 

WriteString(" 2 to sort by extension"); Wri teLn; 

WriteString(" the default is 1, any other is taken ns 1"); 
WriteLn; WriteLn 
END optionMenu; 

PROCEDURE ReadArray(VAR A: ARRAY OF ElemType): CARDINAL; 

VAR n, max : CARDINAL; 

temp : ARRAY [0. .8] OF CHAR; 


PROCEDURE select (option: CARDINAL); 

BEGIN 

CASE option OF ( m compare by: 

1 : comp := compName (# filenames 

| 2 : comp := compExt (#extension 

ELSE comp: s compName (# default 

END 

END select; 


continued 
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BEGIN 

n:= 0; max: = HIGH(A); 

ReadStrlng(temp); 

WHILE (NOT in.eof) & (n< max) DO 
NEW(A[n]); 

Copy(temp,0,30,A[n]".name); 

ReadString(A[n]".ext); 

ReadString(A[n]".size); 

ReadString(A[n]".date); 

ReadString(A[n]*.time); 

ReadString(temp); INC(n) 

END; 

RETURN n 
END ReadArray; 

PROCEDURE WriteArray (A: ARRAY OF ElemType; n: CARDINAL); 

VAR i : CARDINAL; 

BEGIN 

FOR 1: = 0 TO n-1 DO 

WriteFString(A[i]".name,-ll); 
WriteFString(A[i]".ext,-6); 

WriteFString(A[i] \ size,12); 

WriteFString(A[i]".date,10); 
WriteFString(A[i]".time,8); WriteLn 

END 

END WriteArray; 

PROCEDURE WriteFString (s: ARRAY OF CHAR; f: INTEGER); 

(* Write string "s" formated in a field of size f. 

IF f < 0 string is left Justified 
IFf>0 string is right Justified 
IF Length(s)> f string is truncated 
padding is done with blanks 

*) 

VAR i, n: INTEGER; 
c : CHAR; 

BEGIN 

n:= Length(s); 

IF f > 0 THEN FOR i:* 1 TO f-n DO Write( • ») END END; 
i: = 0; 

REPEATc:«s[i]; Write(c); INC(i) 

UNTIL (i>= n) OR (i>= ABS(f)); 

IFf < OTHENFOR i:= 1 TO-f-n DO Write( * ') END END 
END WriteFString; 

PROCEDURE StringComp (si, s2: ARRAY OF CHAR) 

(# returns sl< s2 *) 

VAR i, max : CARDINAL; 

BEGIN 

i:=0; max:= HIGH(sl); 

WHILE (i< max) & (sl[i] * s2[i]) DO 
IF sl[i] = EOS 
THEN RETURN FALSE 
ELSE INC(i) 

END 

END; 

RETURN sl[i]<s2[i] 

END StringComp; 

BEGIN 

comp:= compName (# default #) 

END SortElemType. 


: BOOLEAN; 


(#sl = s2#) 


SORTTEST.MOD From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, 
September 1987. 


(««*** 

« 

* Test of generic sorting routine 

ft 

ftftftftft) 
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MODULE SortTest; 

FROM InOut IMPORT Openlnput, Closelnput, WriteString, WriteLn, ReadCard, 
OpenOutput, CloseOutput; 

FROM Sort IMPORT Qsort; 

FROM SortElemType IMPORT ElemType, select, optionMenu, 

ReadArray, WriteArray; 

CONST 

N = 200; 


VAR 

a : ARRAY [1. .N] OF ElemType; 

n : CARDINAL: (# actual number of elements in "a" #) 

opt : CARDINAL; 

BEGIN 

WriteString("Which file contains the data ? "); 

OpenInput(""); 
n:= ReadArray(a); 

Closelnput; 

optionMenu; 

WriteString("Sort by ? "); 

ReadCard (opt); WriteLn; 
select(opt); 

Qsort(a,n); 

WriteLn; WriteString("Output file [ Esc for console ] ? "); 

OpenOutput(""); 

WriteArray(a,n); 

CloseOutput 
END SortTest. 


SORTELEM.DEF From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, 
September 1987. 


DEFINITION MODULE SortElemType; 

(* This module is intended to describe the elements to be sorted 
# as an abstract data type. 

*) 


TYPE 


EXPORT QUALIFIED ElemType, compare, select, optionMenu, 
ReadArray, WriteArray; 


ElemType; 


PROCEDURE compare (x, y: ElemType): BOOLEAN; 

(* compare(x,y) implements: x< y 

defined as NOT (y <* x), for ascending order; 
and if descending order is desired 
compare(x,y) should implement: x > y 

defined as NOT (x <* y); 

where "<=" denotes a binary relation that must satisfy 
the total order properties: 

1. x<* x 

2. x < = y ANDy <= x ==> x = y 

3. x<= y ANDy<* z ==> x<= z 

4. x<=yORy<=x for every x, y 
*) 


PROCEDURE select (option: CARDINAL); 


(* input: 
output: 


*) 


- a number denoting the requested option 

- the exported compare procedure gets assigned to one 
of the comparison procedures. 

- the option should be valid; otherwise a default 
may be used 


PROCEDURE optionMenu; 
(# output: 


■ displays on the screen the available options. #) 


(* * pointer to data element *) 


continued 
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PROCEDURE ReadArray(VAR A: ARRAY OF ElemType): CARDINAL; 

(* input: - an array of pointers, declared by the user module. 

output: - the array is filled with pointers to the memory used by the elements 

read, and the number of them is returned, 
errors: - can run out of memory. 

NOTE: If the file contains more elements than those that can be stored in the array, they are ignored. 

*) 

PROCEDURE WriteArray(A: ARRAY OF ElemType; n: CARDINAL) ; 

(* input: - an array of pointers, and the number of elements. 

output: - the elements are written to current output of InOut. 

*) 

END SortElemType. 


SORT.MOD From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 
1987. 


IMPLEMENTATION MODULE Sort; 

FROM SortElemType IMPORT ElemType, compare; 

PROCEDURE Qsort (VARA: ARRAY OF ElemType; N: CARDINAL); 

PROCEDURE sort (1, r: INTEGER); (# N. Wirth '86 *) 

VAR i, J : INTEGER; 

x, w : ElemType; 

BEGIN 

i:* 1; J:« r; 
x:» A[(l+r) DIV 2]; 

REPEAT 

WHILE compare(A[i],x) DOINC(i) END; 

WHILE compare(x,A[j]) DODEC(J) END; 

IF i <= J 

THEN w: = A[i]; A[i]:« A[J]; A[J]:=w; 

INC(i); DEC(J) 

END; 

UNTIL i > J ; 

IF 1 < J THEN sort(l,J) END; 

IF i < r THEN sort(i,r) END 
END sort; 

BEGIN 

IF N > HIGH(A)+1 THEN N: = HIGH(A)+1 END; 
sort(0,N-l) 

END Qsort; 

END Sort. 


ADD-PATT.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


i* 

ADD-PATT ADDS A PATTERN TO THE BAM MATRIX XTY 

COPYRIGHT (C) 1987, JOEL S. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR 
NONCOMMERCIAL USE ONLY. 

»/ 

#include "STRUCT.H" 

^include "EXT.H" 
add_patt(an,bn) 
lnt #an,*bn; 

{ 

int 1,J; 
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/* MAKE VECTORS BIPOLAR #/ 
for(i=0;i<#an;i++){ 
if(a[i]<=0){ 
x[i] =-1; 

}else{ 

} 

} 

for(J=0;j<#bn;J++){ 
if(b[j]<=0){ 

y[J] »-i; 

}else{ 

y[J] = 1; 

} 

} 

I* UPDATE XTY »/ 

for(i=0;i<#an;i++){ 

for(j=0;J<#bn;J++){ 

xty[i][J] += x[i]#y[J]; 

} 

} 

/* SIGNAL COMPLETION #/ 

putchar(BELL); 

} 


SORT.DEF From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 
1987. 


DEFINITION MODULE Sort; 

FROM SortElemType IMPORT ElemType, compare; 

(# Module SortElemType is used to define the kind of element to be sorted *) 
EXPORT QUALIFIED Qsort; 

PROCEDURE Qsort (VARA: ARRAY OF ElemType; N: CARDINAL); 

(# input: - array of pointers to elements, and number of elements 

* [ N <= HIGH(A)+1 ]. 

* output: -the array of pointers is rearranged so they point to the 

# elements in sorted order. 

# requires that ElemType has a total order relation named "compare". 

*) 

END Sort. 


README.BAM From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


TO RUN BAM: 

FILESBAM.COM, BAM.PAS, XFACE.INC, PAT1(NOT NECESSARY) 
README.BAM- this file 
> BAM 

*# RUNS THE PROGRAM ** 

SYSTEM REQUIREMENTS: COLOR MONITOR (CGA) OR Mono Graphics 
TURBO PASCAL (FOR EDITING) 

STATUS LINE: PRESSA, S, H, ORQ 


continued 
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ANSWER YES/NO QUESTIONS WITH Y OR N <RETURN>. 

PAT1 is a sample pattern file. 

code 15,712 bytes 
data 49,424 bytes 


FFI: Dr. Rod Taber 

General Dynamics 

Electronics Division Mail Zone 7202-K 
Box 85310 

San Diego, CA 92138 


Mail without Mail Zone takes 3 months. 


AWAIT.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


/* 

AWAIT ASKS THE USER FOR ANOTHER KEY ENTRY AFTER N RETURNS 
*/ 

await(im) 
int im; 

{ 

int i; 


for(i=0;i<im; i++){ 
printf("\n"); 

} 

printf ("Press any key to continue: "); 
getchar(); 


ASYNCH.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


/* 

ASYNCH ASYNCHRONOUSLY UPDATES THE BAM 

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR 
NONCOMMERCIAL USE ONLY. 

*/ 

^include "STRUCT.H" 

^include "EXT.H" 

asynch(axn,ayn,bxn,byn,an,bn,n_asyn) 
int #axn,#ayn,#bxn,#byn,#an,#bn,n_asyn; 

int i,J,k,l,m,n,index,iter,sum; 
int seed; 
char buf[9]; 
double x,frand(); 

/# GET A RANDOM NUMBER SEED FROM THE SYSTEM CLOCK * / 

/ * READ THE CLOCK #/ 
times(buf); 

/* GENERATE THE SEED INTEGER #/ 
seed « (int) (buf[7] - '0'); 
seed +« seed + 10 # ((int) ((buf[6] - ’0'))); 
seed -f= seed + 60 # ((int) ((buf[4] - *0'))); 
seed +* seed+ 600* ((int) ((buf[3] - r 0'))); 
srand(seed); 
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/* GO THROUGH 10 ITERATIONS * / 
iter = 10; 

for(k=0;k<iter;k++){ 

/ * UPDATE N_ASYN NEURONS * / 

for(n=0;n<ruasyn;n++){ 
sum = 0; 

/ * PROCESS B VECTOR NEURON * / 

/* WHICH NEURON DO I UPDATE THIS TIME ? »/ 

x = (double) #bn; 
x#= frand(); 
x += 0.5; 

J = (int) x; 

/ * APPLY ALL A VECTOR INPUTS * / 

for(i=0;i<*an;i++){ 

sum += a[i] # xty[i][j]; 


NOW DO THRESHOLDING */ 
if(sum>0){ 
b[J)-l; 

}else if(sum<0){ 
b[J] =0; 

}else{ 

RETAIN VALUE #/ 
continue; 

} 


vec_show(axn,ayn,bxn,byn); 

/ * NOW IN REVERSE TO PROCESS A VECTOR NEURONS # / 

/ * UPDATE N_ASYN NEURONS * / 

for(n=0;n<n_asyn;n++){ 
sum = 0; 

I * PROCESS B VECTOR NEURON # / 

/* WHICH NEURON DO I UPDATE THIS TIME ? #/ 

x = (double) #an; 
x #= frand(); 
x+= 0.5; 
i » (int) x; 

/ * FOR EACH A VECTOR NEURON, APPLY ALL B VECTOR INPUTS # / 

for(J=0;J<#bn;J++){ 
j sum+« b[J] * xty[i][J]; 

/* NOW DO THRESHOLDING */ 

if(sum>0){ 

a[i]«l; 

}else if(sum<0){ 

a[i] -0; 

)else{ 

/# RETAIN VALUE »/ 

continue; 


vec.show(axn,ayn,bxn,byn); 

} } 


/» 

/« 

} 


SIEVE386.ASM Accompanies "The Kaypro 386" by Ray Duncan, BYTE, September 1987. 


Title "Eratosthenes Sieve for 80386" 
Name Sieve 
Page 50,132 


continued 
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Eratosthenes Sieve for 80386 32-bit protected mode 

Implemented by Ray Duncan, April 1987 

After Gilbreath, BYTE, September 1981 and January 1983 

Here is the MAKE file for this program: 

sieve386.obj : sieve386.asm 
386asm sieve386 

sieve386.exe : sieve386.obj 

386link sieve386 start386 -exe sieve386 -map sieve386 
To run the program with Phar Lap D0S|EXTENDER: 


; -ORUN386 SIEVE386 
i 


niter 

equ 

100 

; number of iterations 

asize 

equ 

8190 

; size of array "flags" 

cr 

equ 

Odh 

; ASCII carriage return 

If 

equ 

Oah 

; ASCII linefeed 

stdin 

equ 

0 

; handle for standard input 

stdout 

equ 

1 

; handle for standard output 

_TEXT 

segment para public use32 1 

'CODE' 


assume cs: _TEXT, ds:_DATA, 

es: JDATA 


public _start_ 

; magic name for RUN386 entry 

_start_ 

proc 

near 



xor 

edx,edx 

; convert number of iterations 


mov 

eax,niter 

; for output 


mov 

ecx,10 



mov 

esi,offset msgla+3 



call 

binasc 



mov 

edx, offset msgl 

; display message 


mov 

ecx,msgJLlen 

; "StartingN iterations of Sieve 


call 

pmsg 



call 

getmsec 

; get current time in msec 


push 

eax 

; and save it... 


mov 

counter,niter 

; initialize iterations counter 

slevel: 



; a sieve iteration starts here.. 


mov 

edi,offset flags 

; initialize flags array 


mov 

ecx,asize 

; to all bytes = TRUE 


mov 

al,l 



cld 




rep stosb 



xor 

esi,esi 

; ESI = index to flags array 


xor 

edi,edi 

; EDI = primes counter 

sleve2: 



; main loop of sieve 


test 

byte ptr flags[esi] 

,1 i is this a prime? 


Jnz 

short sieve4 

; Jump if prime 

sieve3: 

Inc 

esi 

; bump to next slot in "flags" 


cmp 

esi,asize 



Jle 

sieve2 

; loop until array exhausted 


dec 

counter 

; count off sieve iterations 


Jnz 

slevel 

; Jump, another iteration needed. 


Jmp 

sieve7 

; Jump, all iterations finished. 

sieved: 



; prime found, zap its multiples 


mov 

ebx,esi 

; copy i 


mov 

edx,ebx 

; EDX * prime = i + i + 3 


add 

edx,edx 



add 

edx, 3 
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xor al,al 

Jmp short sieve6 

sieve5: mov byte ptr flags[ebx] ,al; zero this multiple 


sieve6: 

add 

ebx,edx 


emp 

ebx,asize 


Jle 

sieved 


inc 

edi 


Jmp 

sieve3 

sieve7: 

call 

getmsec 


push 

eax 


mov 

eax,edi 


mov 

edx,0 


mov 

ecx,10 


mov 

esi,offset msg2a+4 


call 

binasc 


mov 

edx, offset msg2 


mov 

ecx,msg2_len 


call 

pmsg 


pop 

eax 


pop 

ebx 


sub 

eax,ebx 


mov 

edx,0 


mov 

ecx,niter 


idiv 

ecx 


mov 

edx,0 


mov 

ecx,10 


mov 

esi,offset msg3a+4 


call 

binasc 


mov 

edx, offset msg3 


mov 

ecx,msg3_len 


call 

pmsg 


mov 

ax,04C00h 


int 

21H 

_start_ 

endp 


getmsec 

proc 

near 


mov 

ah,2ch 


int 

21h 


movzx 

eax,ch 


imul 

eax,60 


and 

ecx,0ffh 


add 

eax,ecx 


imul 

eax,60 


movzx 

ecx,dh 


add 

eax,ecx 


and 

edx,0ffh 


imul 

eax,100 


add 

eax,edx 


imul 

ret 

eax,10 


getmsec endp 


; find next multiple of prime 
; have we exhausted the array? 
; not yet, zap it 
; count primes and try next 


; all done, get current time 


; convert number of primes 
; found on last iteration 


; display "Number of primes: " 


; calculate total elapsed msec. 


; divide by number of iterations 
; to get msec per iteration 


; convert msec to ASCII 


; display "Elapsed time:" 


; final exit, return code = 0 


; Return EAX = current time in msec. 

; read time 

; EAX : ■ hours 
; hours -> minutes 
; isolate system minutes 
; and find total minutes 
; minutes -> seconds 
; isolate system seconds 
; and find total seconds 
; isolate hundredths 
; seconds -> hundredths 
; find total hundredths 
; hundredths -> msec 


; BINASC: Convert 64-bit binary value to ASCII string. 
i 

i Call with EDX:EAX = signed 64-bit value 
; ECX ■ radix 

; DS:ESI = last byte of area to store resulting string 

i (make sure enough room is available to store 

i the string in the radix you have selected.) 

i 

; Destroys EAX, EBX, ECX, EDX, and ESI. 


continued 
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binasc 

proc 

near 

; convert EDX:EAX to ASCII. 


mov 

byte ptr [esi], 'O' 

; force storage of at least one digit. 


or 

edx,edx 

; test sign of 64-bit value, 


pushf 


; and save sign on stack. 


jns 

binl 

; Jump if it was positive. 


not 

edx 

; negative, take 2's complement 


not 

eax 

; of the value. 


add 

eax,l 



adc 

edx,0 


binl: 

mov 

ebx,eax 

; divide 64-bit value by the radix 
; to extract next digit for the 
; forming string. 

; is the value zero yet? 


or 

ebx,edx 



Jz 

bin3 

; yes, we are done converting. 


call 

divide 

; no, divide by radix. 


add 

bl,'0» 

; convert remainder to ASCII digit. 


cmp 

bl,*9* 

; might be converting hex ASCII, 


Jle 

bin2 

; Jump if in range 0-9, 


add 

bl, , A'- , 9 , -l 

; correct it if in range A-F. 

bin2: 

mov 

[esi],bl 

; store this character into string. 


dec 

esi 

; back up through string, 


Ji"P 

binl 

; and do it again. 

bin3: 

popf 


; restore sign flag, 

; was original value negative? 


jns 

bin4 

; no, jump 


mov 

byte ptr [esi], 

; yes, store sign into output string. 

bin4: 

ret 


; back to caller. 

binasc endp 



; General-purpose 64-bit by 32-bit unsigned divide. 

; This must be used instead of the plain machine unsigned divide 
; for cases where the quotient may overflow 32 bits. If called with 

; zero divisor, 

this routine returns the dividend unchanged and gives 

; no warning. 



; Call with EDX:EAX = 64-bit dividend 



ECX 

=divisor 


; Returns EDX:EAX = quotient 



EBX 

= remainder 



ECX 

= divisor (unchanged) 

divide 

proc 

near 

; Divide EDX:EAX by ECX 


Jecxz 

divl 

; exit if divide by zero 


push 

eax 

; O:dividend_upper/divisor 


mov 

eax,edx 



xor 

edx,edx 



div 

ecx 



mov 

ebx,eax 

; EBX a quotientl 


pop 

eax 

; remainderl:dividendLlower/divisor 


div 

ecx 



xchg 

ebx,edx 

; EDX:EAX = quotientl:quotient2 

divl: 

ret 


; EBX = remainder2 

divide 

endp 



pmsg 

proc 

near 

; print a message on std output 
; call with DS:EDX » address 




; ECX =length 


mov 

ah,40h 



mov 

bx,stdout 



int 

21h 



pmsg 


ret 

endp 


_TEXT 


ends 


_DATA segment para public use32 'DATA' 
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flags 

db 

asize+1 dup (?) 

counter 

dd 

? . 

msgl 

db 

cr,If,'Starting ' 

msgla 

db 

' iterations of Sieve. 

msgl_len 

equ $-msgl 

msg2 

db 

or. If,' Primes found: 1 

msg2a 

db 

' ',cr,lf 

msg2_len 

equ $-msg2 

msg3 

db 

cr, If,' Elapsed time: ' 

msg3a 

db 

' msec, per iteration' 

msg3_len 

equ $-msg3 

-DATA 

ends 


-STACK 

segment byte stack use32 ’stack' 


db 

4096 dup (?) 

-STACK 

ends 



end 



i sieve iteration counter 


GET_MTX.C 


From "Constructing an Associative 

\ 


Memory" by Bart Kosco, BYTE, September 1987. 


/* 

GET_MTX GETS THE VALUES FOR AN XTY MEMORY MATRIX FROM MASS STORAGE 

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY. 
*/ 

^include <c: \cware\stdio.h> 

^include <struct.h> 

0include <ext.h> 

ge t_mtx(axn,ayn,bxn,byn,an,bn) 

int *axn,*ayn,#bxn,#byn,*an,*bn; 

int i,J,total; 

FILE #f3,#fopen(); 
char fname[40]; 

for(;;){ 

for(i=0; i <40; i++) fname[i] *0; 
clsO(); 

printf("\n\n\nPlease enter name of file containing memory values"); 
printf( "\nyou wish to restore: "); 
scanf("|s",fnamc); 

/* OPEN INPUT FILE #/ 

if ((f>fopcn( fnnmo, "r")) --NULL) { 
printf("\nCan't open INPUT FILE |s\n", fname); 
printf("\nTry againl Hit [ENTER] to continue... "); 
getchar(); 

}else{ 

break; 

} 

} 

/* CLEAR THE BAM »/ 
clearbam(); 

/* READ HORIZONTAL AND VERTICAL DIMENSIONS OF A AND B ARRAYS */ 
fscanf (f3,"Id Id Id |d",axn,nyn,bxn,byn); 
printf("\n\n Reading A array Id x Id and B array |d x Id", 

#axn,#ayn,*bxn,#byn); 

*an * (#axn) * (#ayn); 

#bn ■ (#bxn) # (#byn); 
total« (#an) * (#bn); 


continued 
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printf("\n*dx$d xTy -> $d lines to be read! ",#an,*bn,total); 
printf("\nDepending upon your machine, this could take a minute or so..."); 

for(i=0;i<*an;i++){ 
for(j=0;j <#bn;j++){ 
fscanf(f3/'$d",&xty[i] [j]); 

} 

} 

fclose(f3); 


} 


PAT1 From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


4 

4 

8 

6 

10 

11111111100000011111111110000001 

000111000000001100000000110000000011000000001100000001111000 

11111111000110000001100000011000 

011111111011000000110000000011000111111001110000001111111111 

11111111100000011000000111111111 

110001100011000110001100011000111111111100000110000000011000 

11100111101111011001100110000001 

111111111100000000110000001110000011100000111000001110000000 


EXT.H From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


/* 

BAM PARAMETER ARRAYS 

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY. 

*/ 

extern int a[DIMENl],b[DIMEN2],x[DIMENl],y[DIMEN2],xty[DIMENl][DIMEN2]; 
extern int newvecl[DIMENl],newvec2[DIMEN2]; 


BAM.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


/• 

PROGRAM BAM 

========================== 

BY 

JOELS. DAVIS 

1310 CONSTITUTION COURT, NE 
ALBUQUERQUE, NM 87112 


THIS PROGRAM IS A SIMPLE IMPLEMENTATION OF THE BIDIRECTIONAL CORRELATION MEMORY ALGORITHM DEVELOPED BY BART KOSKO. THE SOURCE CODE 
IS WRITTEN FOR DESMET C BY CWARE RUNNING UNDER MS-DOS. 

IT COMBINES FEATURES FROM THE DUANE DESIENO BAM PROGRAM, WRITTEN IN BASIC, AND MY OWN ASSOC AND BASSOC PROGRAMS, WRITTEN IN C. 

THIS VERSION IS DATED: 7-AUGUST-1987 

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY. 

*/ 
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^include <\cware\stdio.h > 

^include <\cware\math.h> 

^include <struct.h> 

Int a[DIMENl],b[DIMEN2],x[DIMENl],y[DIMEN2],xty[DIMENl][DIMEN2]; 
int newvecl[DIMENl],newvec2[DIMEN2]; 


main(argc,argv) 
int argc; 
char ##argv; 

{ 

int i, j ,k,l,m,n,d2; 
int op; 

int axn,ayn,bxn,byn,n_asyn,pct_noise,an,bn; 


/* INITIALIZE DIMENSIONS */ 

clearbam(); 

initial(&axn,&ayn,&bxn,&byn,&an,&bn,&n_asyn,&pc t__no ise); 

/* INTRODUCTION #/ 

intro(); 

/* PRESENT MAIN MENU */ 

f°r(;;){ 

op = mainmenu(); 

if(op == l){ 

/ * NEW PROGRAM PARAMETERS # / 

nev_parm( &axn, &ayn, &bxn, &byn, &an, &bn, &n_asyn, &pct_noise); 

}else if(op==2){ 

I * CLEAR VECTORS AND BAM * / 

clearbam(); 

}else if(op==3){ 

/ * LOAD THE MEMORY MATRIX » / 

ge t_mtx (&axn, &ay n, &bxn, &byn, &an, &bn); 

}else if(op==4){ 

/* SAVE THE MEMORY MATRIX # / 

save_mtx(&axn,&ayn,&bxn,&byn,&an,&bn); 

}else if(op==5){ 

/ * OPERATE ON MEMORY AND RUN BAM # / 

rurubam(&axn,&ayn,&bxn,&byn,&an,&bn,n_asyn,pc t_noise); 

}else if(op==6){ 

/* QUIT */ 

break; 


CLEARBAM.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987. 


/» 

CLEARBAM CLEARS ALL BAM VECTORS AND THE XTY MATRIX 


COPYRIGHT (C) 1987, JOEL S. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY. 

*/ 

^include <STRUCT.H> 

^include <EXT.H> 

clearbam() 

{ 

int d2; 

/ * SET MATRICES TO ZERO * / 
zero_ld(a,DIMENl); 
zero_ld(b,DIMEN2); 


continued 
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zero_ld(x,DIMENl); 
zero_ld(y,DIMEN2); 
zero_ld(nevvecl,DIMENl); 
zero_ld(newvec2,DIMEN2); 

/* NOW 2-DIMENSIONAL VECTORS, WHICH WILL BE TREATED LIKE 1-D VECTORS */ 
d2 = DIMEN1* DIMEN2; 
zero_ld(xty,d2); 

} 


SIEVE86.ASM Accompanies "The Kaypro 386" by Ray Duncan, BYTE, September 1987. 


Title "Eratosthenes Sieve for 80x86 Real Mode" 
Name Sieve 
Page 50,132 


; Eratosthenes Sieve for 80x86 Real Mode 
; Implemented by Ray Duncan, April 1987 
; After Gilbreath, BYTE, September 1981 and January 1983 


niter 

equ 

100 

; number of iterations 

asize 

equ 

8190 

; size of array "flags" 

cr 

equ 

Odh 

; ASCII carriage return 

If 

equ 

Oah 

; ASCII linefeed 

stdin 

equ 

0 

; handle for standard input 

stdout 

equ 

1 

; handle for standard output 

.TEXT 

segment para public 'CODE' 



assume cs:_TEXT,ds:_DATA,es:.DATA 

sieve 

proc 

near 



mov 

ax,seg JDATA 



mov 

ds,ax 



mov 

es,ax 



mov 

dx,0 

; convert number of iterations 


mov 

ax,niter 



mov 

cx,10 



mov 

si, off set msgla+3 



call 

blnasc 



mov 

dx,offset msgl 

; display message 


mov 

cx,msgl_len 

; "StartingN iterations of Sieve 


call 

pmsg 



call 

getmsec 

; get current time in msec 


push 

dx 

; and save it ... 


push 

ax 



mov 

counter,niter 

; initialize iterations counter 

slevel: 

mov 

di, off set flags 

; a sieve iteration starts here.., 
; initialize flags array 


mov 

cx,asize 

; to all bytes « TRUE 


mov 

cld 

rep stosb 

al,l 



xor 

si,si 

; SI ■ index to flags array 


xor 

di,di 

; DI = primes counter 

sieve2: 

test 

byte ptr flags [ s i ], 1 

; main loop of sieve 
; is this a prime? 


Jnz 

short sieve4 

; Jump if prime 
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sieved: inc 

si 

; bump to next slot in "flags" 

emp 

si,asizc 

; are we done? 

Jle 

sieve2 

; Jump to test another 

dec 

word ptr counter 

; more iterations? 

Jnz 

sievel 

; jump, another iteration needed 

Jmp 

sleve7 


sieve4: 

bx,sl 

; prime found, zap its multiples 

mov 

; copy i 

mov 

dx,bx 

; DX = prime = i + i + 3 

add 

dx,dx 

add 

dx,3 


xor 

al,al 


Jmp 

short m1ovo6 


sieve5: mov 

by to ptr flags|bx],al 

; zero this multiple 

sieve6: add 

bx,dx 

; find next multiple of prime 

emp 

bx,a«lse 

; have we exhausted the array? 

Jle 

slovo^ 

; not yet, zap it 

inc 

di 

; count primes and try next 

Jmp 

siev#3 

sieve7: 


; done with all iterations... 

call 

gotmaoo 

; get current time 

push 

dx 

; and save it... 

push 

ax 


mov 

ax,dl 

; convert number of primes 

mov 

dx,0 

mov 

ox ,10 


mov 

offset msg/aU 


call 

blntso 


mov 

dx, offset m«g;’ 

; display "Number of primes:" 

mov 

ox, mug.* Ion 

call 

pm«« 


pop 

ax 

; stop time: low word 

pop 

dx 

# high word 

pop 

bx 

; start time: low word 

pop 

ox 

# high word 

sub 

ox,bx 

; DX:AX = stop - start 

sbb 

dx,ox 

mov 

ox,niter 

i divide by number of iterations 

idiv 

ox 

mov 

dx,0 

; convert msec to ASCII 

mov 

ox, 10 


mov 

si, offset mug la»4 


call 

blneso 


mov 

dX,Off set msg I 

; display "Elapsed time:" 

mov 

ox,magi l«n 


call 

pm«| 


mov 

nx, 040001) 

; exit to DOS with 

int 

2111 

; return code = 0 

sieve endp 

getmsec proo 

near 

; DX : AX : = current time in msec. 

mov 

nli,2oh 

i read time from MS-DOS 

lnt 

21h 

push 

dx 

; save seconds, hundredths 

mov 

«l, <ili 

; AX : = hours 

cbv 

mov 

bx,60 

; hours -> minutes 

lmul 

bx 

xor 

oh, eh 

; Isolate system minutes 


continued 
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add 

ax,cx 

; and find total minutes 

mov 

bx,60 

; minutes -> seconds 

imul 

bx 


pop 

CX 

; recover seconds, hundredths 

mov 

bl,ch 

; get seconds 

xor 

bh,bh 


add 

ax,bx 

; find total seconds 

adc 

dx,0 

; carry if necessary 

xor 

ch,ch 

; save centisec. 

mov 

bp,cx 

; total seconds * 100 the hard way 

mov 

bx,ax 

; double multiply # 10 

mov 

cx,dx 


add 

ax, ax 

; *2 

adc 

dx,dx 


add 

ax, ax 

; *4 

adc 

dx,dx 


add 

ax,bx 

; * 5 

adc 

dx,cx 


add 

ax, ax 

; * 10 

adc 

dx,dx 


mov 

bx,ax 

; double multiply * 10 

mov 

cx,dx 


add 

ax, ax 

; *2 

adc 

dx,dx 


add 

ax, ax 

; *4 

adc 

dx,dx 


add 

ax,bx 

; *5 

adc 

dx,cx 


add 

ax, ax 

; * 10 

adc 

dx,dx 


add 

ax, bp 

i add in hundredths of seconds 

adc 

dx,0 

; now convert total to msec. 

mov 

bx,ax 

; double multiply # 10 

mov 

cx,dx 


add 

ax, ax 

; * 2 

adc 

dx,dx 


add 

ax, ax 

• *4 

adc 

dx,dx 


add 

ax,bx 

; * 5 

adc 

dx,cx 


add 

ax, ax 

; * 10 

adc 

dx,dx 


ret 


; return DX:AX = msec. 


getmsec endp 

; BINASC: Convert 32-bit binary value to ASCII string. 

; Call with DX:AX = signed 32-bit value 
; CX - radix 

} SI = last byte of area to store resulting string 

; (make sure enough room is available to store the string in the radix you have selected.) 

; Destroys AX, BX, CX, DX, and SI. 


binasc 

proc 

near 

; convert DX:AX to ASCII. 


mov 

byte ptr [si], 'O' 

; force storage of at least one digit 


or 

dx,dx 

; test sign of 32-bit value, 


pushf 


; and save sign on stack. 


Jns 

binl 

j Jump if it was positive. 


not 

dx 

; negative, take 2's complement 


not 

ax 

; of the value. 


add 

ax,l 



adc 

dx,0 


binl: 



j divide 32-bit value by radix 




; to extract next digit for the 




; forming string. 


mov 

bx,ax 

; is the value zero yet? 


or 

bx,dx 
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Jz 

bin3 


call 

divide 


add 

bl,'0» 


cmp 

bl,'9' 


Jle 

bin2 


add 

bi/A’-'g’-i 

bin2: 

mov 

[si],bl 


dec 

Ml 


Jmp 

binl 

bin3: 

popf 



jns 

bln4 


mov 

byte ptr [si], 

bin4: 

ret 


binasc 

endp 



; yes, we are done converting. 

; no, divide by radix. 

; convert remainder to ASCII digit. 
; might be converting to hex ASCII, 

; Jump if in range 0-9, 

; correct it if in range A-F. 

; store this character into string. 
; back up through string, 

; and do it again. 

; restore sign flag, 

; was original value negative? 

; no, Jump 

; yes, store sign into output. 

; back to caller. 


General-purpouo hi I by If.-bit unsigned divide. 

This must be usod In..I..I r l.ho plain machine unsigned divide for cases where the quotient may overflow 16 bits 

(for example, dividing 100,000 by 2). If called with a zero divisor, this routine returns the dividend unchanged 
and gives no warning. B 


Call with DX:AX « hit dividend 
CX • dlvl 101 


Returns DX:AX ■ •lUotlmit 


i 

BX 

■ romnlnder 


i 

i 

CX 

■ divisor (unchanged) 


divide 

proc 

near 

; Divide DX:AXby CX 


Jcxz 

dlvl 

; exit if divide by zero 


push 

nx 

i 0:dividend_upper/divisor 


mov 

nx, dx 



xor 

dx,dx 



div 

ox 



mov 

bx,nx 

; BX = quotientl 


pop 

AX 

; remainderl:dividend_lower/divisor 


div 

ox 



xchg 

bx,ilx 

; DX:AX = quotientl:quotient2 

divl: 

ret 


i BX ■ remainder2 

divide 

endp 



pmsg 

proc 

near 

j print a message on std output 




; call with DS.-EDX = address 




l ECX = length 


mov 

Ahi40lt 



mov 

bx,«tdout 



int 

21h 



ret 



pmsg 

endp 



_TEXT 

ends 



_DATA 

segment |»u « pub Mo ’DATA' 


flags 

db 

amImi | dup (7) 


counter 

dw 

r 


msgl 

db 

•»•'# If i '(lUrtlng ' 


msgla 

db 

! Urntloiwi of Sieve... ' ,cr,lf 

msgl_len equ $ 

magi 


msg2 

db 

"i » 1 ('i ’l‘rl m« n found: ' 


msg2a 

db 

* »,or,lf 


msg2_len equ $ 

flllgtl 


msg3 

db 

Oi'ilf, 'llnpned tlmo: • 


msg3a 

db 

roaeo, per i teration 

1 >cr,lf 

msg3_len equ t 

meg l 



continued 
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.DATA 

ends 


.STACK 

segment byte stack 'stack 


db 

4096 dup (?) 

.STACK 

ends 



end 

sieve 


TURBFLOP.PRO Contributed by Alex Lane. From "ALS Prolog,” BYTE, September 1987. 


/* Floating-Point Test Program */ 
/* */ 
/# written in Turbo Prolog #/ 

/* 6-10-87 a.lane */ 

/* */ 
/# result for 5000 repetitions: */ 
/# 30 seconds */ 


predicates 

float_point 
time_l( integer ) 
cycle( integer, real, real, real ) 
calc( real, real, real, real ) 

goal 

float_point. 

clauses 

float_point 

write( ’'Enter number of repetitions: " ), 
readint( Iters ), 
time_l( Start), 

cycle( Iters, 1.0, 2.71828, 3.1*159 )i 
time_l( Finish ), 

Overall = Finish - Start, 
write( "Time is " ), 
write( Overall) ,nl. 

calc( C,CF,A,B ) 

Cl = C # A, 

C2 = Cl # B, 

C3 = C2/ A, 

CF = C3 / B. 


cycle( 0,C,_,_) 

write( "C is " ), 
write(C ),nl. 

cycle( N,C,A,B ) 

ealc(C,CF,A,B), 

N1 = N - 1, 
oyole(Nl,CF,A,B). 

time_l( Time ) 

/# quick and dirty; won't work across midnight *1 
/# and ignores hundreths of a second #/ 

time( H,M,S,_ ), 

Time = S + 60 ^ (M + 60*H). 


KAREX2.BAS Accompanies the article "Karmarkar's Algorithm" by Andrew M. Rockett and John C. Stevenson, BYTE, September 1987. 


100 • 
101 ' 


102 ' KAREX2.BAS is a Microsoft BASIC Release 5 program 

103 * that solves EXAMPLE 2 of the article 

104 • 

105 ’ KARMARKAR' S ALGORITHM 


L 
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106 ' 

107 * by Andrew M. Rockett and John C. Stevenson 

108 • 

109 ’ This program was written by Andrew M. Rockett 

110 ' 

111 '.. 

200 ' 

202 ' N is the number of unknowns and K is the number of equations 
204 * 

206 N = 8 : K = 4 
208 • 

210 K1 = K + 1 : K2 = 2*K1 

212 DIM A0(N), X0LD(N), XNEW(N), CC(N), CP(N), 

A(K,N), B(K1,N), B1(K1,K2), B2(N,K1), B3(N,N) 

214 FOR C = 1 TO N : A0(C) = 1/N : XNEW(C) = A0(C) : 

NEXT C 
216 » 

218 ' T is the tolerance 
220 ■ 

222 T = .001 
224 ' 

226 ' ALPHA is usually set equal to 1/4 ... 

228 ' 

230 ALPHA = .25 
232 • 

234 ITERATION = 0 
236 ' 

238 ' Data for constraint matrix A 
240 ' 

242 DATA 1, 0, 1, 0, 0, 0, 1, -3 
244 DATA 1, 0, 0, -1, 0, 0, 2, -2 
246 DATA 0, 1, 0, 0, 1, 0, 3, -5 
248 DATA 0, 1, 0, 0, 0, -1, 4, -4 
250 1 

252 FOR R = 1 TO K : F0RC = 1T0N : READA(R,C) : 

NEXT C : NEXT R 
254 ' 

256 * Data for objective function CC 
258 ' 

260 DATA 0, 0, 0, 0, 0, 0, 1, 0 
262 ' 

264 FOR C « 1 TO N : READ CC(C) : NEXT C 
266 • 

268 V = 0 : FOR C«1 TO N : V = V + CC(C)*A0(C) : 

NEXT C : VNEW = V 
270 ' 

272 ' Main iteration process is the same as in KAREX1.BAS ... 

274 ' 

300 WHILE VNEW/V>T 

301 PRINT USING "HHH "; ITERATION;: 

FOR C«1 TO N: PRINT USING "M#. MM";XNEW(C); : 

NEXT C : PRINT USING "MM.MMM#";VNEW/V 

302 ITERATION = ITERATION + 1 

303 FOR C - 1 TO N : XOLD(C) =» XNEW(C) ; NEXT C 

304 FOR R=1 TO K: FOR C=1 TO N:B(R,C)=A(R,C)#XOLD(C): 

NEXT C: NEXT R 

305 FOR C=1 TO N:B(K1,C)*1;NEXT C 

306 FOR R=1 TO K1 : F0RC=1T0K2 : B1(R,C)=0 : 

NEXT C : NEXT R 

307 FOR R-l TON : F0RC*1T0K1 : B2(R,C)=0 : 

NEXT C : NEXT R 

308 FOR R=1 TO N : FOR CHITON : B3(R,C)*0 : 

NEXT C : NEXT R 

309 FOR C-l TO N : CP(C) » 0 : NEXT C 

310 FOR R=1 TO Kl: FOR C=1 TO Kls 

FOR 1=1 TO N:B1(R,C)=B1(R,C)+B(R,I)#B(C,I): 

NEXT I: 

NEXT C: NEXT R 

311 FOR I = 1T0K1 : B1(I,I+K1)*1 : NEXT I 

312 FOR R = 1 TO Kl 

313 IF B1(R,R) <>0 THEN 318 

314 I - R + 1 

315 IF I > Kl THEN PRINT 'Error! BBT is SINGULAR!' ; 

GOTO 407 


continued 
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316 IFBl(I,R) = 0THEN 1*1+1: GOTO315 

317 FOR C = 1 TO K2 : SWAP B1(R,C),B1(I,C) : NEXT C 

318 FOR I = R+l TO K1:Z = Bl(I,R)/Bl(R,R): 

FOR C=1 TO K2:Bl(I,C)=Bl(I,C)-Z*Bl(R,C):NEXT C: 

NEXT I 

319 NEXT R 

320 FOR R=K1 TO 2 STEP -1:FOR I = R-l TO 1 STEP -1:Z = Bl(I,R) /B1(R,R): 
FOR C=R TO K2:B1(I,C)=B1(I,C)-Z#B1(R,C):NEXT C: 

NEXT I:NEXTR 

321 FOR R=1 TO K1:Z = B1(R,R): 

FOR C=1 TO K2:B1(R,C)=B1(R,C)/Z:NEXT C: 

NEXT R 

322 FOR R=1 TO N: FOR C=1 TO K1: 

FOR J=1 TO K1:B2(R,C)=B2(R,C)+B(J,R)#B1(J,C+K1): 

NEXT J: 

NEXT C: NEXT R 

323 FOR R=1 TO N: FOR C=1 TO N: 

F0RJ=1T0K1:B3(R,C)=B3(R,C)+B2(R,J)*B(J,C): 

NEXT J: 

NEXT C: NEXT R 

324 FOR R = 1 TO N : B3(R,R) = B3(R,R) -1 : NEXT R 

325 FOR R=1 TO N:FOR C=1 TO N:B3(R,C)=-1*B3(R,C): 

NEXT C: NEXT R 

326 FOR R=1 TO N:FOR C=1 TO N:B3(R,C)=B3(R,C)*XOLD(C): 

NEXT C: NEXT R 

327 FOR R=1 TO N:FOR C=1 TO N:CP(R)=CP(R)+B3(R,C)*CC(C): 

NEXT C: NEXT R 

328 AA=0:F0R C=1 TO N : AA = AA + CP(C)#CP(C) : NEXT C 

329 AA = SQR( AA) : FOR C=1 TO N : CP(C) * CP(C) / AA : 

NEXT C 

330 AA = SQR(N#(N-l)) / ALPHA 

331 FOR C=1 TON : XNEW(C) * (A0(C) - CP(C)/AA)*XOLD(C) : 

NEXT C 

332 AA=0:F0R C=1 TO N : AA = AA + XNEW(C) : NEXT C 

333 FOR C=1 TO N : XNEW(C) = XNEW(C)/AA : NEXT C 

334 VNEW=0: FOR C=1 TO N: VNEW=VNEW+CC(C)»XNEW(C) :NEXT C 

335 WEND 

336 » 

400 PRINT:PRINT*Tolerance reached: Vnew/Vinltial = 

VNEW/V:PRINT 

401 PRINT USING "W; ITERATION; : 

FOR C=1 TO N:PRINT USING **M0.MM";XNEW(C); : NEXT C : 

PRINT USING *'; VNEW/ V 

402 ' 

403 ' Project solution from simplex back to orthant ... 

404 * 

405 PRINT: FOR C=1 TO N-2:PRINT XNEW(C)/XNEW(N), : ■ 

NEXT C: PRINT 

406 » 

407 END 


KAREX1.BAS Accompanies the article "Karmarkar's Algorithm*' by Andrew M. Rockett and John C. Stevenson, BYTE, September 1987. 


100 

101 

102 

103 

104 

105 

106 

107 

108 

109 

110 
111 
200 
202 
204 


KAREX1.BAS is a Microsoft BASIC Release 5 program that solves EXAMPLE 1 of the article 


KARMARKAR'S ALGORITHM 
by Andrew M. Rockett and John C. Stevenson 
This program was written by Andrew M. Rockett 


N is the number of unknowns and K is the number of equations 


206 N » 3 : K « 1 
208 ' 

210 K1 = K + 1 : K2 « 2#K1 
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212 DIM AO(N), XOI.D(N), XNKW(N), CC(N), CI>(N), A(K,N), B(K1,N), B1(K1,K2), B2(N,K1), B3(N,N) 

214 1 

216 ' CC is for tho objootlvo (‘unction 
218 ' Bl, B2 and B3 ore uaod for tho computation of CP 
220 1 R and C are "row" and "column" Indices 
222 » 

224 ' Initially, sotXNcw AO, the 'Utor of simplex 
226 • 

228 FOR C = 1 TO N: A0(C) 1/N : XNFW(C) - A0(C) : NEXT C 

230 » 

232 ' T is the toloranoo 
234 • 

236 T= .001 
238 ' 

240 ' ALPHA is usuii I ly riM nqun I to 1 , ; 4 .,. 

242 r 

244 ALPHA => .25 
246 ' 

248 ITERATION - 0 
250 ' 

252 r Data for count mint mat 1 I« A 
254 • 

256 DATA 2, -3, 1 
258 ' 

260 FOR R ■ 1 TO K : I < )H r I I D N I FAD A(R,C):NEXT C:NEXT R 
262 » 

264 » Data for object lv.« (’»»»».' 1 l.-n n: 

266 ' 

268 DATA 3, 3, I 
270 • 

272 FORC ■ 1 TO N : HI AIM r(t ) ; NI X 1 ( 

274 • 

276 ' Set initial Value ti» vuhie »»i cantor of simplex ... 

278 ' 

280 V = 0 : FOR C 1 TON V V • (Mi - •» A()( C) jNEXTC: VNEW = V 
282 » 

284 • Now wo can bry in tlmMAIN I i I J j A r ION process ... 

286 ' 

300 WHILE VNEW/V > T 

301 ' 

302 PRINT USING "NNMH" * I l HtA M<>ii, M >k ( -1 TO N: PRINT USING EW(C); : NEXT C : PRINT USING NEW/V 

304 ITERATION ITI'RAI MN . 1 

305 ' 

306 ' Put Xnow 1|<M X..M 

307 ' 

308 FOR C ■ 1 TON l Xol,|»( 1 > XN! Wh ) : NEXTC 

309 ’ 

310 ' Construct, 1 lm mat. 1 ■ n 

311 ' 

312 FOR R*1 TO K 1 1'Olt ( I I'm N |ur,< ) A(R,C)#X0LD(C) : NEXT C : NEXT R 

313 FOR C l TON IM K I .<• I 1 hi ■ 

314 • 

315 ' Zero inatrliuiN !.m lm nmni ... u tot ions... 

316 • 

317 FOR IM TO HI FOlK'-l M h.' IU(R,C)-0 : NEXT C : NEXT R 

318 FOR R-l TO N !<>IH l MM 1 '(It ,C) -0 : NEXT C : NEXT R 

319 FOR R-I TON I m|i 1 1 111 n in < It , 0 ) 0 : NEXT C : NEXT R 

320 FOR C-l TON ' Id ) 0 HI-HI 

321 ' 

322 ' Find BUT ami | 'ii in n 1 

323 1 

324 FOR H - II" » 1 1 - -Mmm mum 1 TO N:B1(R,C)=B1(R,C)+B(R, I)#B(C, I): NEXT I: NEXT C : NEXT R 

325 ’ 

326 • Adjoin an l.i. 1 • 1 * .. . 1 . - 

327 ' 

328 FOR I - I TO X I i«l( 1 , hi 1 ) l ni-.X'l I 

329 ' 

330 ' Row reduce nit 1 1 1 

331 ' 

332 FOR R - I MM 

333 IF Bl(Rfli) • • II I III 1 N l IM 

334 I - R • I 

335 IF I > M 'IIll'll 1 hi 111 "I ri'Mfl hill In !NGULAR!": GOT0 400 

336 IF III(1 ,10 1 Mill'll I •• 1 1 1 mu 135 


continued 
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337 FOR C * 1 TO K2 : SWAP B1(R,C) ,B1(I,C) : NEXT C 

338 FOR I « R+l TO K1 : Z = B1(I,R)/B1(R,R): FOR 0*1 TO K2:Bl(I,C)sBl(I,C)-Z*Bl(R,C): NEXT C:NEXT I 

339 NEXT R 

340 » 

341 ' Now back substitute to finish it ... 

342 ' 

343 FORR » K1 TO2STEP-1 : FOR I - R-lTO 1 STEP-1 : Z ■ B1(I,R)/B1(R,R) s FOR C = R TO K2:B1(I,C)=B1(I,C)-Z*B1(R,C): NEXT C: NEXT I 
:NEXT R 

344 ' 

345 Remember to make diagonal entries l's 

346 ' 

347 FORR=1 TO K1 : Z - B1(R,R) : F0RC-1T0K2 : B1(R,C) ■ B1(R,C)/Z : NEXT C : NEXTR 

348 » 

349 ' BBT Inverse is now in B1 in columns Kl+1 to K2 

350 ' 

351 ' Now multiply BBT Inverse by BT and put in B2 

352 ' 

353 FOR R * 1 TO N : F0RC-1T0K1 : FOR J * 1 TO K1:B2(R,C)=B2(R,C)+B(J,R)*B1(J,C+K1) :NEXT J:NEXT C : NEXT R 

354 • 

355 ' Take THAT and multiply by 3 and put in B3 

356 • 

357 FOR R * 1 TO N : FOR C * 1 TO N : F0RJ*1T0 K1:B3(R,C)«B3(R,C)+B2(R, J)*B(J,C) :NEXT J:NEXT C : NEXT R 

358 ' 

359 ' Find I-B3 by subtracting l's on diagonal and changing signs 
361 ' 

362 FOR R = 1 TO N : B3(R,R) * B3(R,R) - 1 : NEXT R 

363 FOR R-l TO N: FOR C-l TO N:B3 (R, C) = -1*B3(R,C):NEXT C: NEXT R 

364 » 

365 ' Multiply by D 

366 ' 

367 FOR R«1T0N:F0RC»1T0N:B3(R,C)=B3(R,C)*X0LD(C):NEXT C:NEXT R 

368 ' 

369 ' Find projection of CC and call it CP 

370 ' 

371 FOR R-l TO N: FOR C-l TO N:CP(R)«CP(R)+B3(R,C)*CC(C):NEXT C:NEXT R 

372 ' 

373 ' Find length of CP and the normalized CP 

374 » 

375 AA = 0 

376 FOR C-l TO N : AA * AA + CP(C)*CP(C) : NEXT C 

377 AA » SQR(AA) : F0RC=1T0N : CP(C) *CP(C)/AA : NEXT C 

378 ' 

379 'Find a*, project back to get new X ... 

380 ' 

381 AA = SQR(N*(N-1))/ALPHA 

382 FOR C-l TON : XNEW(C) « (A0(C) - CP(C)/AA)*XOLD(C) : NEXT C 

383 ' 

384 ' And remember to divide by "size" of new X to complete the projective transformation 

385 ' back to the original simplex 

386 ' 

387 AA = 0 

388 FOR C*1 TO N : AA = AA + XNEW(C) : NEXT C 

389 FOR C-l TON : XNEW(C) =XNEW(C)/AA : NEXT C 

390 ' 

391 ' Find objective function Value at NEW point X 

392 ’ 

393 VNEW = 0 

394 FOR C=1 TO N : VNEW = VNEW + CC(C)*XNEW(C) : NEXT C 

395 ' 

396 WEND ' End of main iteration loop ... 

397 ' 

398 PRINT:PRINT"Tolerance reached: Vnew/Vinitial = VNEW/V:PRINT 

399 PRINT USING "M##" j ITERATION; : FOR C*1 TO N: PRINT USING "###.####" ;XNEW(C); : NEXT C : PRINT USING "WM.UmU"', VNEW/V 

400 END 
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BBS’S POSTING BYTENET LISTINGS 


Australia: 

Grayham Smith 
12 Brentwood Road 
Flinders Park, South Australia 5025 
The Electronic Oracle 
300 Baud, CCITT Standard 
Telephone: 08-43-3331 Vbice 
08-260-6686 BBS 

Edward A. Romer 
31 Warwick Street 
Killara, 

Sydney NSW. Australia 2071 
OMEN 

300 & 1200 Baud 
Telephone: 02-498-2399 
Voice (Work) 

02-499-2642 Voice (Home) 

02-498-2495 BBS 

Alan Salmon 
PCUG Sysop 
GPO Box 2229 
Canberra. 

A.C.T, 2601. Australia 
Canberra PC Users Group Inc. 

300 & 1200 Baud 
Telephone: 61-62-58-9967 BBS 

Angus S. Bliss 
POB 293 

Hamilton NSW 2303, Australia 

Newcastle Microcomputer Club 

300 Baud. CCITT Standard, 8 Bits, 1 Stop. No Parity 

Telephone: 049-67-2433 Voice (Angus Bliss) 

049-54-9505 Voice (Tony Nicholson) 
61-49-685385 BBS 

John Hastwell-Batten 
POB 242 

Dural, NSW 2158, Australia 
Tesseract RCPM+ 

300 Baud. CCITT Standard. 8 Bits. No Parity 
Telephone: 02-651-2363 Voice 
02-651-1404 BBS 

Phil Harding 
POB 35 

Charnwood A.C.T.. Australia 2615 
PC-Exchange Bulletin Board 
300 & 1200 Baud, CCITT Standard 
Telephone: 61-062-581406 Vbice 
61-62-586352 BBS 

Eric Salter 
POB 60 

Canterbury 3126. Australia 

MICOM: The Microcomputer Club of Melbourne 

300 Baud 

Telephone: 61-3-861-9117 Eric Salter 

61-3-762-1386 Peter Jetson (SYSOP) 
61-3-762-5088 BBS 

Craig Bowen 

29 Warrigal Road 

Surrey Hills 3127, Vic., Australia 

Public Resource HI 

300 Baud. CCITT Standard. 8 Bits, 1 Stop. No Parity 
Telephone: 03-890-2174 

John Blackett-Smith 
Unit 8 

69 Wattle Road 
Hawthorn 3122, Australia 
The National Fido 
Telephone: 613-818-2336 


Austria: 

Wotfpng Hryzak 
3ahnstrasse 48 
X-2230 Gansemdorf. Austria 
1 lersin of Vienna BBS FIDO 
300 Baud. 8 Bits. 1 Stop Bit 
Tdephooe: 02282-24094 BBS 

Brazil: 

Stsiema Sampa 
ATTN Rizieri Maglio 
R Bxtugal. 202 
Jdm Europe - CEP 01446 
Sao Paulo - SP - Brazil 
Sisiema Sampa 

} X L . 200 Baud. CCITT Standard 
Tekphooe: 011-8536273 BBS 

Canada: 

Leigh Calnek 
3036 25th Avenue 

Rei.ru. Saskatchewan, Canada S4S 1K9 
Telephone: 306-586-9253 BBS 

Torn Kashuba 

PCOMM Systems 

:-l 1 Fort Street, Suite 2001 

Montreal, Quebec. Canada H3H 2N7 

Telephone: 514-989-9450 BBS 

Gary McCallum 

Western Canadian Distribution Center 
3420 48th Street 

Edmonton. Alberta. Canada T6L 3R5 
300 & 1200 & 2400 Baud 
Telephone: 403-462-9189 Voice 
403-461-9124 BBS 

Judson Newell 

Canada Remote Systems 

Suite 311,4198 Dundas Street West 

Toronto. Ontario. Canada M8X 1Y6 

Telephone: 416-231-2383 Voice 

416-231-9202 BYTEnet System 

Vernon Paige 
EPSNUNK 
3 McNicoll Avenue 

Willowdale. Ontario. Canada M2H 2A6 
300 & 1200 Baud 
Telephone: 416-494-1380 Voice 
416-635-9600 BBS 

Terry Smythe 
Sysop, Z-Nodc 40 
Muddy Water User Group 
55 Rowand Avenue 

Winnipeg, Manitoba, Canada R3J 2N6 
Telephone: 204-832-3982 Vbice 
204-945-6713 Voice 
204-832-4593 BBS 


Chile: 

Eurique Benavides Z. 

Guillermo Gomara C. 

Eliodoro Yanez 2210 
Providencia 
Santiago de Chile 
BIGSA BBS 

2400/1200 300 Bell & CCITT 
Telephone: 562-49*4$ 

10:00 am to 4 00 am Clfekaa^me* 
Downloads & Uploads 
Xmodem ASCII 


Denmark: 

Beverly Kleiman 
International Representative 
Personal Computer Society of Denmark 
Kronprinsensgade 14, 

DK-1114 Copenhagen, Denmark 
300 Baud. CCITT Standard 
Telephone: 01-122518 BBS 

England: 

Frank Thornley 
67 Woodbridge Road. 

Guildford, 

Surrey GU21 UP. United Kingdom 
CompuLink 

Telephone: 0-483-65895 Vbice 

0-483-573337 (300/1200 Baud) BBS 
0-483-573338 (1200/2400 Baud) BBS 

Finland: 

Juha Wiio 
Databox Oy 
Museokatu 11 
00100 Helsinki. Finland 
DATABOX FIDO 
300 & 1200 Baud 
Telephone: 358-0-497904 

Vivian Ronald Dwight 
Suvikuja 3 B 14 
02120 Espoo. Finland 
Micro Maniacs III Fido Node 17 
300 & 1200 &. 2400 Baud 
Telephone: 358-0-424524 Vbice 
358-0-4557307 Voice 
358-0-467673 BBS 

France: 

Bill Graham. 

President 

OUF! (Ordinateurs Utilisateurs France) 

ATTN: OUFLOG. B P. 62 
10 rue Saint Nicolas 
75012 Paris, France 
300 Baud. CCITT Standard 
Telephone: 331-43-44-06-48 Vbice (Bill) 
331-43-44-82-65 Vbice 
331-43-41-61-47 OUFLOG 
for BYTE Listings 
331 -43-40-33-79 OUFTEL 
300 & 1200 Baud 
331 -43-07-95-39 OUFTEL 

Dr. Bernard Pidoux 

Groupe Des UtUisaicurs Francophones D Tnformatique 

37. Boulesard Samt-Jacques 

750U Pans. France 

300 Baud. CCITT Standard 

Telephone 1-47-63-72-50 Vbice 

1 -45-65-10-09 GUFINET 
1-45-65-10-11GUFITEL 

Hong Kong: 

W A Hanafi 
SEAnet 

Suite 812. Star House. 

Tsim Sha Tsui. Kowloon. Hong Kong 
ATTN: Christine Wong 
Telephone: 5-455088 Vbice 

5-8937856 SEAnet 1 
5-724495 SEAnet 2 

continued 
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Indonesia: 

James D. Filgo 

US Embassy Box R 

APO SF 96356-5000 

Jakarta Computer Society 

300 Baud. Bell & CCITT Standard 

Telephone: 062-21-799-3286 BBS 

Israel: 

Zohar Levitan 
POB 10279 
Tshala 61102 
Israel 

(Contact for telephone number) 

Ireland: 

Gerry Clarke 
30 Auburn Road 

Dunlaoire County. Dublin, Ireland 
Dublin Bax Bulletin Board 
300 & 1200 Baud 
Telephone: 353-01-854179 

Italy: 

Bruno Bonino 
MICRO design s.r.l. 

Via Rostan, 1 
16155 Genova, Italy 
C.B.B.S. 

CCITT & Bell Standard 
Telephone: 10-687098 Voice 
10-688783 BBS 

Giorgio Leo Rutigliano 
Via degli Oleandri, 7 
POB 175 

85100-Fotenza, Italy 

FIDO-PZ 

300 Baud 

Telephone: 0971-34593 Voice (Work) 

0971-54431 Voice (Home) 
0971-35447 BBS 

Claudio Vandelli 
Amministratore Unico 
SOFT SERVICE s.r.l. 

ViaG. B. Morgagni 32 
20129 Milano, Italy 
SOFT SERVICE BBS 

300 Baud, CCITT Standard. 8 Bits, No Parity, 
Duplex 

Telephone: 02-209231 Voice 
02-228467 BBS 

Paolo Marraffa 
Computronix 
Via De Amicis 76 
90145 Palermo, Italy 
Network Computer Club 

300 Baud, CCITT Standard. 8 Bits, 1 Stop Bit, 
Duplex 

Telephone: 39-91-266021 BBS 
39-91-300229 BBS 


Japan: 

Peter Perkins 
Vice President 

Honda Trading Company Ltd. 

Mail 101 

9-91-Chome, Sota Kanda 
Chiyoda-ku, Tokyo, Japan 
JAN/S 

300 & 1200 Baud. CCITT Standard 
Telephone: 03-251-0855 BBS 

Malaysia: 

Ong Boo Huat 
3. Jalan Pi sang 

Jalan Kelang Lama. 58000 Kuala Lumpur 

STARUNK 

300 Baud 

Telephone: 03-7578811 X 116 Vbice 
03-7576644 BBS 

Nigeria: 

Chester W. Vlaun 
MTCE/31 
POB 263 

Port Harcourt. Nigeria, West Africa 
300 Baud 

Telephone: 234-84-301210 to 301229-3022 

Norway: 

Robert Hertz 
Hertz Data Inc. 

Huitssfeldts Gate 16 
N-0253 Oslo, Norway 
Hacker s Unlimited 
Telephone: 47-2-431655 Voice 
47-2-390521 BBS 

Helge Vindenes 
5670 FUSA, Norway 
Costa del 

Telephone: 47-5-151610 Vbice 
47-5-234129 BBS 

Saudi Arabia: 

Larry Layland 
System Operator DPCS 
Aramco 
Box 10063 

p u j] Dhahran, Saudi Arabia 31311 

Dhahran Personal Computing Society Bulletin Board 
Telephone: 03-873-7851 BBS 

Singapore: 

Ken Ong 

10 Orange Grove Road 
*04-01 

Singapore 1025, Singapore 
K B B S 

Fu ll 300 & 1200 Baud 

Telephone: (IDD) 65-734-5825 Voice 
(IDD) 65-737-4090 BBS 


Sweden: 

Jacob Palme 

Stockholm University Computer Centre-QZ 
Box 27322 

102 54 Stockholm, Sweden 
BYTECOM 

Telephone: 46-8-65-45-00 Voice (Work) 

08-23-86-60 (300 Baud) 

08-23-89-30(300 Baud) 

08-15-59-20(300 Baud) 
08-14-35-00(1200 Baud) 
08-22-81-30(1200 Baud) 
08-24-61-20(1200 Baud) 
08-14-53-70(1200 Baud) 

Carl Nordin 

Nyakersgatan 8B 

531 41 Lidkoping, Sweden 

A.T.L 

300 & 1200 Baud. CCITT Standard 
Telephone: 46-510-25280 Vbice 
46-510-20409 BBS 

Switzerland: 

Peter M. C. Werner 
9, rue de la Colombiere 
1260 Nyon, Switzerland 
OCTET 

300 & 1200 & 2400 Baud, CCITT Standard 
Telephone: 41-22-62-16-54 Voice 
41-22-62-18-17 BBS 

Albert F. Sluder 
Technical Director 
Kupfer Electronic AG 
Soodstrasse 53 

Fostfach, 8134 Adliswil, Switzerland 
TRAX 

300 Baud, CCITT Standard 
Telephone: 01-710-81-11 Vbice 
01-710-44-36 BBS 

The Netherlands: 

Henk Wevers 

Cloeckendaal 38 

6715 GH Ede, The Netherlands 

Henk Wevers ’ Fido 

Telephone: 31-8380-37156 BBS 

West Germany: 

Rupert Mohr 

RMI Nachrichtentechnik GmbH 
RosstraBe 7 
Postfach 1526 

D-5100 Aachen, West Germany 
RMI Net 

Telephone: 49-241-21145 Vbice 

45-2410-90528 BYTEnet - DATEX-P 
0-26245-2410-90528 User Data - DATEX-P 

Rudolf Strieker 
Unsoeldstr. 20 

D-8000 Munich 22, West Germany 
T-BUS FIDO 

Telephone: 089-29-38-81 BBS 
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Announcing BYTE’s 
New Subscriber Benefits 


Y 

Xoi 


Program 


.our BYTE subscription brings 
you a complete diet of the latest in 
microcomputer technology every 
30 days. The kind of broad-based 
objective coverage you read in 
every issue. In addition, your 
subscription carries a wealth of 
other benefits. Check the check 
list: 

DISCOUNTS 

13 issues instead of 12 if you 
send payment with subscription 
order. 

One-year subscription at S21 
(50% off cover price). 

Two-year subscription at S38. 

Three-year subscription at S55. 

Ef One-year GROUP subscription 
for ten or more at S17.50 each. 
(Call or write for details.) 

SERVICES 

si BIX: BYTE’s Information 
Exchange puts you on-line 24 
hours a day with your peers 
via computer conferencing and 
electronic mail. All you need to 
sign up is a microcomputer, a 
modem, and telecomm 
software. 

Reader Service: For information 
on products advertised in 
BYTE, circle the numbers on 
the Reader Service card 
enclosed in each issue that 
correspond to the numbers for 
the advertisers you select. Drop 
it in the mail and we’ll get 
your inquiries to the advertisers. 

(jj TIPS: BYTE’s Telephone 
Inquiry System is available to 


EVTE 



subscribers who need fast 
response. After obtaining your 
Subscriber I.D. Card, dial TIPS 
and enter your inquiries. You’ll 
save as much as ten days over 
the response to Reader Service 
cards. 

Disks and Downloads: 

Listings of programs that 
accompany BYTE articles are 
now available free on the 
BYTEnet bulletin board, and 
on disk or in quarterly printed 
supplements. 

^ Microform: BYTE is available 
in microform from University 
Microfilm International in the 
U.S. and Europe. 

BYTE's BOMB: BYTE s 
Ongoing Monitor Box is your 
direct line to the editor's desk. 
Each month, you can race the 
articles via the Reader Service 
card. Your feedback helps us 


keep up to date on your 
information needs. 

Customer Service: If you have 
a problem with, or a question 
about, your subscription, you 
may phone us during regular 
business hours (Eastern time) 
at our toll-free number: 800- 
258-5485. You can also use 
Customer Service to obtain 
back issues and editorial indexes. 

BONUSES 

Annual Separate Issues: In 
addition to BYTE’s 12 monthly 
issues, subscribers also receive 
our annual IBM PC issue free 
of charge, as well as any other 
annual issues BYTE may 
produce. 

^ BYTE Deck: Subscribers 
receive five BYTE postcard 
deck mailings each year—a 
direct response system for you 
to obtain information on 
advertised products through 
return mail. 

To be on the leading edge of 
microcomputer technology and 
receive all the aforementioned 
benefits, make a career decision 
today. Call toll-free weekdays, 
8:30am to 4:30pm Eastern time: 
800-258-5485. 

And. . . welcome to 
BYTE country! 


BITE 

THE SMALL SYSTEMS JOURNAL 


m 









Borland’s new TUrbo C: 

The most powerful 
optimizing compiler ever 


O ur new Turbo C 
generates fast, 
tight, production- 
quality code at compilation 
speeds of more than 
13,000* lines a minute! 

It’s the full-featured 
optimizing compiler 
everyone has been waiting 
for. 

Switching to TUrbo C, or 
starting with TUrbo C, you 
win both ways 

If you’re already' programming 
in C, switching to Turbo C will 
make you feel like you’re riding 
a rocket instead of pedaling a 
bike. 

If you’ve never programmed 
in C, starting with Turbo C gives 
you an instant edge. It’s easy to 
learn, easy to use, and the most 
efficient C compiler at any price. 


6 6 Turbo C does look like 
What We’ve All Been Waiting 
For: a full-featured compiler 
that produces excellent 
code in an unbelievable 
hurry... moves into a class 
all its own among full- 
featured C compilers ... 
Turbo C is indeed for the 
serious developer ... One 
heck of a buy—at any 

price. Michael Abrash, 

Programmer's Journal J / 


Join more than 100,000 Turbo C 
enthusiasts. Get your copy of 
Turbo C today! 


A. Borland products are trademark* or registered trademarks o» Borland interna- 
tonat. me. or Bor and Anayica. tnc Ott* Orard and product names are trade¬ 
marks or registered trademarks oi me* respect* riders 
Copyright 1987 Borand Internationa BM136 



For the dealer nearest you or to order by phone call 

(800) 255-8008 

in CA (800) 742-1133 in Canada (800) 237-1136 


BORLAND 

INTERNATIONAL 


4585 SC0TTS VALLEY DRIVE 
SC0TTS VALLEY, CA 95066 
(408)438-8400 TELEX: 172373 


Only $99.95! 


Technical Specifications 

ST Compiler. One-pass optimizing com¬ 
piler generating linkable object 
modules. Included is Borland's high- 
performance Turbo Linker The object 
module is compatible with the PC- 
DOS linker. Supports tiny, small, com¬ 
pact medium, large, and huge 
memory model libraries. Can mix mod¬ 
els with near and far pointers. Includes 
floating point emulator (utilizes 8087/ 
80287 if installed). 

S' Interacts Editor The system includes 
a powerful, interactive full-screen text 
editor. If the compiler detects an error, 
the editor automatically positions the 
cursor appropriately m the source 
code. 

S' Development Environment A powerful 
"Make" is included so that managing 
Turbo C program development is 
highly efficient Also includes pull¬ 
down menus and windows. 

Sf Links with relocatable object modules 
created using Borland's Turbo Prolog • 
into a single program. 

S' Inline assembly code. 

S' Loop optimizations 

S f Register variables 

ST ANSI C compatible. 

3 f Start-up routine source code included. 

Bf Both command line and integrated 
environment versions included. 

S' License to the source code for Run¬ 
time Library available. 


Sieve benchmark 



Turbo C 

Microsoft* 

C 

Compile time 

2.4 

13-51 

Compile and 
link time 

4.1 

18.13 

Execution 

time 

395 

5.93 

Object code 
size 

239 

249 

Execution 

size 

5748 

7136 

Price 

$99.95 

$450.00 


’Benchmark nil on an IBM PS 2 Model 60 using Turt>o C version 1.0 and 
me lrt>o U*er version 10. Microsoft C version 40 and tne MS overlay 
Imker version 3.51 


Minimum system requirements: 3¥ PC. XT. AT. PS 2 and true ccmoat des 
PC-D0S (MS-DOS) 20 or ater 384< 

















